#if !defined(STAND_ALONE)
#endif
#define _SMEMORY 1
!-----------------------------------------------------------------------
!         Nasa/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS
!-----------------------------------------------------------------------
      MODULE parutilitiesmodule
#if defined( SPMD )
!BOP
!
! !MODULE: parutilitiesmodule
!
! !USES:
#if defined( STAND_ALONE )
# define iulog 6
#else
      use cam_logfile, only: iulog
#endif
#if !defined(STAND_ALONE)
      USE shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8, &
                              r4 => shr_kind_r4
#endif
      USE mod_comm, ONLY : commglobal, gid, numpro, blockdescriptor, max_nparcels
#include "debug.h"
      IMPLICIT NONE
#include "mpif.h"
#include "pilgrim.h"

!
! !PUBLIC DATA MEMBERS:
      PUBLIC     Gsize
      PUBLIC     INT4, REAL4, REAL8
      PUBLIC     SUMOP, MAXOP, MINOP, BCSTOP
       

      INTEGER,SAVE :: GSize        ! Size of communicator CommGlobal
                                   ! Equivalent to mod_comm::numpro
#define CPP_SUM_OP 101
#define CPP_MAX_OP 102
#define CPP_MIN_OP 103
#define CPP_BCST_OP 104

      INTEGER,SAVE :: INT4  = MPI_INTEGER
      INTEGER,SAVE :: REAL4 = MPI_REAL
      INTEGER,SAVE :: REAL8 = MPI_DOUBLE_PRECISION
      INTEGER,SAVE :: SUMOP = MPI_SUM
      INTEGER,SAVE :: MAXOP = MPI_MAX
      INTEGER,SAVE :: MINOP = MPI_MIN
      INTEGER,SAVE :: BCSTOP = CPP_BCST_OP

! !PUBLIC MEMBER FUNCTIONS:
      PUBLIC ParPatternType

      TYPE ParPatternType
        INTEGER ::     Comm                  ! Communicator
        INTEGER ::     Iam                   ! My rank in communicator
        INTEGER ::     Size                  ! Size of communicator
        TYPE(BlockDescriptor), POINTER :: SendDesc(:) ! Array of descriptors
        TYPE(BlockDescriptor), POINTER :: RecvDesc(:) ! Array of descriptors
      END TYPE ParPatternType 


#ifdef _SMEMORY
      TYPE ParInfoType
        INTEGER :: numRecvSeg               ! number of received segments
        INTEGER :: numSendSeg               ! number of send segments
        INTEGER :: maxNumSeg                ! maximum number of segments over all processors
        INTEGER :: numRecvNeigh             ! number of receive neighbors
        INTEGER :: numSendNeigh             ! number of send neighbors
      END TYPE ParInfoType
#endif

      PUBLIC     ParInit, ParSplit, ParFree, ParExit
      PUBLIC     ParScatter, ParGather
      PUBLIC     ParBeginTransfer, ParEndTransfer
      PUBLIC     ParExchangeVector, ParCollective
      PUBLIC     ParPatternCreate, ParPatternFree

      INTERFACE     ParPatternCreate
        MODULE PROCEDURE ParPatternCopy
        MODULE PROCEDURE ParPatternGhost
        MODULE PROCEDURE ParPatternDecompToDecomp
        MODULE PROCEDURE ParPatternDecompToGhost
        MODULE PROCEDURE ParPatternGhostToDecomp
        MODULE PROCEDURE ParPatternGhostToGhost
      END INTERFACE
 
      INTERFACE     ParScatter
        MODULE PROCEDURE ParScatterReal
        MODULE PROCEDURE ParScatterReal4
        MODULE PROCEDURE ParScatterInt
      END INTERFACE
 
      INTERFACE     ParGather
        MODULE PROCEDURE ParGatherReal
        MODULE PROCEDURE ParGatherReal4
        MODULE PROCEDURE ParGatherInt
      END INTERFACE

      INTERFACE     ParBeginTransfer
        MODULE PROCEDURE ParBeginTransferReal
        MODULE PROCEDURE ParBeginTransferPattern1D
        MODULE PROCEDURE ParBeginTransferPattern1Dint
        MODULE PROCEDURE ParBeginTransferPattern2D
        MODULE PROCEDURE ParBeginTransferPattern3D
        MODULE PROCEDURE ParBeginTransferPattern4D
!        MODULE PROCEDURE ParBeginTransferInt
      END INTERFACE

      INTERFACE     ParEndTransfer
        MODULE PROCEDURE ParEndTransferReal
        MODULE PROCEDURE ParEndTransferPattern1D
        MODULE PROCEDURE ParEndTransferPattern1Dint
        MODULE PROCEDURE ParEndTransferPattern2D
        MODULE PROCEDURE ParEndTransferPattern3D
        MODULE PROCEDURE ParEndTransferPattern4D
!        MODULE PROCEDURE ParEndTransferInt
      END INTERFACE

      INTERFACE     ParExchangeVector
        MODULE PROCEDURE ParExchangeVectorReal
        MODULE PROCEDURE ParExchangeVectorReal4
        MODULE PROCEDURE ParExchangeVectorInt
      END INTERFACE

      INTERFACE     ParCollective
        MODULE PROCEDURE ParCollectiveBarrier
        MODULE PROCEDURE ParCollective0D
        MODULE PROCEDURE ParCollective1D
        MODULE PROCEDURE ParCollective1DReal4
        MODULE PROCEDURE ParCollective2D
        MODULE PROCEDURE ParCollective2DReal4
        MODULE PROCEDURE ParCollective3D
        MODULE PROCEDURE ParCollective0DInt
        MODULE PROCEDURE ParCollective0DStr
        MODULE PROCEDURE ParCollective1DInt
        MODULE PROCEDURE ParCollective1DStr
        MODULE PROCEDURE ParCollective2DInt
      END INTERFACE

#ifdef _SMEMORY
      INTERFACE   ParCalcInfo
        MODULE PROCEDURE ParCalcInfoDecompToGhost
        MODULE PROCEDURE ParCalcInfoDecompToDecomp
        MODULE PROCEDURE ParCalcInfoGhostToGhost
        MODULE PROCEDURE ParCalcInfoGhostToDecomp
      END INTERFACE
#endif

!
! !DESCRIPTION:
!
!      This module provides the basic utilities to support parallelism
!      on a distributed or shared memory multiprocessor.
!
!      \begin{center}
!      \begin{tabular}{|l|l|} \hline \hline
!        ParInit           & Initialize the parallel system \\ \hline
!        ParExit           & Exit from the parallel system \\ \hline
!        ParSplit          & Create a Compute grid of PEs   \\ \hline
!        ParFree           & Free a split communicator \\ \hline
!        ParScatter        & Scatter global slice to local slices \\ \hline
!        ParGather         & Gather local slices to one global \\ \hline
!        ParBeginTransfer  & Initiate an all-to-all packet transfer \\ \hline
!        ParEndTransfer    & Complete an all-to-all packet transfer \\ \hline
!        ParExchangeVector & Complete an all-to-all packet transfer \\ \hline
!        ParCollective     & Collective operation across communicator \\ \hline
!      \end{tabular}
!      \end{center}
!      \vspace{2mm}
!
!      Other utilities can be added to this module as needs evolve.
!
!      Conceptually the intention is to aggregate as many of the
!      MPI communication calls as possible into a well-maintained
!      module.  This will help avoid the occurrence of MPI spaghetti 
!      code.  
!
!      This module is tailored to GEOS DAS and implements the 
!      design of Lucchesi/Mirin/Sawyer/Larson.
!
! !REVISION HISTORY:
!   97.02.01   Sawyer     Creation
!   97.07.22   Sawyer     Removal of DecompType related subroutines
!   97.08.13   Sawyer     Added ParScatter/Gather for Integers
!   97.09.26   Sawyer     Additions of Sparse communication primitives
!   97.12.01   Sawyer     Changed all MPI_SSEND to MPI_ISEND
!   97.12.23   Lucchesi   Added member variables IsIONode and InterComm
!   98.01.06   Sawyer     Additions from RL for I/O Nodes
!   98.02.02   Sawyer     Added the Cartesian data members
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.02.23   Sawyer     Added ghosting utilities
!   98.02.25   Sawyer     Modified interface of BeginTransfer
!   98.03.03   Sawyer     Added Global ID number to public data members
!   98.03.25   Sawyer     Added documentation for walkthrough
!   98.04.16   Sawyer     Removed all use of MPI_CART (CommRow redefined)
!   98.07.23   Sawyer     Added ParGhost, ParPoleDot; ParBegin/EndGhost out
!   98.09.15   Sawyer     Added ParMerge, ParPoleGhost
!   98.09.17   Sawyer     Added ParSum, removed ParPoleDot
!   99.01.18   Sawyer     Minor cleaning
!   99.03.04   Sawyer     Revised SHMEM concept for Transfer
!   99.04.22   Sawyer     Removed COMMON for handles -- they are
!                         always used in same program unit.
!   99.05.21   Sawyer     Reintroduced barriers in Scatter/Gather
!   99.06.03   Sawyer     USE_SHMEM revisions
!   99.12.10   Sawyer     ParInit now sets GID, Gsize
!   99.12.13   Sawyer     Version slimmed down for FVCCM release
!   00.06.14   Sawyer     Precision module now used
!   00.07.07   Sawyer     Removed 2D scatter/gather; simplified API
!   00.07.30   Sawyer     Full implementation with shared memory
!   00.08.09   Sawyer     Replaced ParSum with ParCollective
!   00.08.28   Sawyer     Moved LLNL 2D data to LLNL2DModule; new MLP impl
!   01.02.04   Sawyer     Added PatternType and related routines
!   01.02.12   Sawyer     Converted to free format
!   02.10.30   Sawyer     Welded with mod_comm
!   03.03.06   Sawyer     Fix parpatterncreate for MPI2; use MPI_DATATYPE_NULL
!   05.10.12   Worley     Support for vectorization modifications in mod_comm
!   06.03.01   Sawyer     Merged CAM and GEOS5 versions
!   07.01.05   Mirin      Eliminated direct use of Gsize
!   07.09.04   Dennis     Reduced temporary memory usage
!
! !BUGS:
!   There are several MPI_Barriers at locations in the code.
!   These avoid potential race conditions which probably only occur
!   if the number of real processors is less than the number of
!   message passing processes.  Remove these barriers at your own risk
!
!EOP

      INTEGER, SAVE :: InHandle(MAX_PAX, MAX_SMP, MAX_TRF)
      INTEGER, SAVE :: OutHandle(MAX_PAX,MAX_SMP, MAX_TRF)
      INTEGER, SAVE :: BegTrf = 0  ! Ongoing overlapped begintransfer # 
      INTEGER, SAVE :: EndTrf = 0  ! Ongoing overlapped endtransfer #
      LOGICAL, SAVE :: Initialized = .FALSE. ! Flag for initialization of parutilitiesmodule.

      CONTAINS
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParInit --- Initialize the parallel execution
!
! !INTERFACE: 
      SUBROUTINE ParInit ( Comm, npryzxy, mod_method, mod_geopk, mod_gatscat, mod_maxirr )
!
! !USES:
      USE mod_comm, ONLY : mp_init
      IMPLICIT NONE
! !INPUT PARAMETERS:
      INTEGER, OPTIONAL  :: Comm
      INTEGER, OPTIONAL, INTENT(IN) :: npryzxy(4)      ! 2D decompositions
      INTEGER, OPTIONAL, INTENT(IN) :: mod_method      ! CAM optimization
      INTEGER, OPTIONAL, INTENT(IN) :: mod_geopk       ! CAM optimization
      INTEGER, OPTIONAL, INTENT(IN) :: mod_gatscat     ! CAM optimization
      INTEGER, OPTIONAL, INTENT(IN) :: mod_maxirr      ! CAM max simul. trsps.

!
! !DESCRIPTION:
!     Initializes the system.  In MPI mode, call MPI\_INIT if not done 
!     already. If the optional arguments are not provided, default 
!     values will be chosen.  But it is advisable to provide COMM
!     (main communicator) and NPRYZXY (internal 2D decomposition).
!
! !SYSTEM ROUTINES:
!     MPI_INITIALIZED, MPI_INIT
!
! !REVISION HISTORY:
!   97.03.20   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.07.03   Sawyer     Reformulated documentation
!   00.07.23   Sawyer     Added shared memory arena implementation
!   02.10.30   Sawyer     Now uses mp_init from mod_comm
!   06.06.15   Sawyer     Added CAM optimizations (passed to mod_comm)
!
!EOP
!-----------------------------------------------------------------------
!BOC

! Initialize mod_comm

      IF (.NOT. Initialized) THEN
         CALL mp_init( Comm, npryzxy, mod_method, mod_geopk, mod_gatscat, mod_maxirr )
         Gsize = numpro   !   Support PILGRIM's Gsize for now
         Initialized = .TRUE.
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParInit
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParExit --- Finalize the parallel execution
!
! !INTERFACE:
      SUBROUTINE ParExit ( Comm )

! !USES:
      USE mod_comm, ONLY: mp_exit
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, OPTIONAL  :: Comm

! !DESCRIPTION:
!     All PEs, compute nodes and IO nodes alike meet here to terminate
!     themselves.  If someone does not check in, everything will hang
!     here.
!
!     This routine is the very {\em last} thing which is executed!
!
! !LOCAL VARIABLES:
      INTEGER Ierror
!
! !SYSTEM ROUTINES:
!     MPI_BARRIER, MPI_FINALIZE
!
! !REVISION HISTORY:
!   97.03.20   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.07.03   Sawyer     Reformulated documentation
!   00.07.23   Sawyer     Added shared memory arena implementation
!   02.08.13   Sawyer     Incorporated mod_comm for low level comm.
!
!EOP
!-----------------------------------------------------------------------
!BOC
      CALL mp_exit(Comm)
      RETURN
!EOC
      END SUBROUTINE ParExit
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParSplit --- Split into group for I/O and computation
!
! !INTERFACE:
      SUBROUTINE ParSplit( InComm, Color, InID, Comm, MyID, Nprocs )
!
! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )     :: InComm    ! Communicator to split
      INTEGER, INTENT( IN )     :: Color     ! Group label
      INTEGER, INTENT( IN )     :: InID      ! Input ID

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )    :: Comm      ! Split communicator
      INTEGER, INTENT( OUT )    :: MyID      ! Group label
      INTEGER, INTENT( OUT )    :: Nprocs    ! Number of PEs in my group
!
! !DESCRIPTION:
!     This routine splits the PEs into groups.  This is currently only
!     supported in MPI mode. Read the chapter on MPI\_COMM\_SPLIT 
!     thoroughly.  
!
! !SYSTEM ROUTINES:
!     MPI_COMM_SPLIT, MPI_COMM_SIZE, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.03.20   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.07.03   Sawyer     Reformulated documentation
!   97.12.01   Sawyer     Xnodes and Ynodes are explicit arguments
!   97.12.23   Lucchesi   Added call to MPI_INTERCOMM_CREATE
!   98.01.06   Sawyer     Additions from RL for I/O Nodes
!   98.02.02   Sawyer     Added the Cartesian information
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.04.16   Sawyer     Removed all use of MPI_CART (CommRow redefined)
!   99.01.10   Sawyer     CommRow now defined for all rows
!   00.07.09   Sawyer     Removed 2D computational mesh
!   00.08.08   Sawyer     Redefined as wrapper to mpi_comm_split
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER  Ierror

      CPP_ENTER_PROCEDURE( "PARSPLIT" )
!
!     Split the communicators
!
      CALL MPI_COMM_SPLIT( InComm, Color, InID, Comm, Ierror )
      IF ( Comm .ne. MPI_COMM_NULL ) THEN
        CALL MPI_COMM_RANK( Comm, MyID, Ierror )
        CALL MPI_COMM_SIZE( Comm, Nprocs, Ierror )
      ELSE
!
!     This PE does not participate: mark with impossible values
!
        MyID = -1
        Nprocs = -1
      ENDIF

      CPP_LEAVE_PROCEDURE( "PARSPLIT" )
      RETURN
!EOC
      END SUBROUTINE ParSplit
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParFree --- Free a communicator
!
! !INTERFACE:
      SUBROUTINE ParFree( InComm ) 
!
! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER InComm

!
! !DESCRIPTION:
!     This routine frees a communicator created with ParSplit
!
! !REVISION HISTORY:
!   97.09.11   Sawyer     Creation, to complement ParSplit
!   00.07.24   Sawyer     Revamped ParMerge into a free communicator 
!
! !LOCAL VARIABLES:
      INTEGER  Ierror
!
!EOP
!-----------------------------------------------------------------------
!BOC
      CPP_ENTER_PROCEDURE( "PARFREE" )
!
      CALL MPI_COMM_FREE( InComm, Ierror ) 
      CPP_LEAVE_PROCEDURE( "PARFREE" )
      RETURN
!EOC
      END SUBROUTINE ParFree
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternCopy --- Duplicate/replicate a comm pattern
!
! !INTERFACE:
      SUBROUTINE ParPatternCopy( InComm, PatternIn, PatternOut, Multiplicity )
!
! !USES:
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(ParPatternType), INTENT( IN )   :: PatternIn   ! Comm Pattern
      INTEGER, INTENT( IN ),  OPTIONAL     :: Multiplicity

! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: PatternOut  ! Comm Pattern
!
! !DESCRIPTION:
!     This routine duplicates a given communication pattern. 
!
!     Optionally a multiplicity can be added.  This replicates the
!     communication pattern Mult times, that is for the case that
!     the data structures are replicated in the final dimension
!     Mult times.  A typical example is a pattern describing a 2D
!     array, e.g. a a lat-lon decomposition, which will be used
!     to copy a 3D lat-lon-lev array.  The strides (e.g. the number
!     of elements in one plane) of the source (send) and target 
!     (recv) arrays are now calculated internally.
!
! !SYSTEM ROUTINES:
!     MPI_TYPE_UB, MPI_TYPE_HVECTOR, MPI_TYPE_COMMIT
!
! !REVISION HISTORY:
!   03.03.20   Sawyer     Creation
!   03.06.26   Sawyer     Removed StrideSend/Recv from API
!
!EOP 
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER  Stride_S, Stride_R, Mult, Iam, GroupSize, Ipe, Ierror
      INTEGER  Disp, Length, I, J, ub, method

      CPP_ENTER_PROCEDURE( "PARPATTERNCOPY" )

      method = PatternIn%RecvDesc(1)%method

!
! Decide if this is a simple copy, or a multiple replication
!
      IF ( present(Multiplicity) ) THEN
          Mult = Multiplicity
      ELSE
          Mult = 1
      ENDIF

      CALL MPI_COMM_DUP( PatternIn%Comm, PatternOut%Comm, Ierror )
      CALL MPI_COMM_SIZE( PatternIn%Comm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( PatternIn%Comm, Iam, Ierror )

      PatternOut%Iam  = Iam
      PatternOut%Size = GroupSize

      ALLOCATE( PatternOut%SendDesc( GroupSize ) )
      ALLOCATE( PatternOut%RecvDesc( GroupSize ) )

      PatternOut%SendDesc(:)%method = PatternIn%SendDesc(:)%method
      PatternOut%RecvDesc(:)%method = PatternIn%RecvDesc(:)%method
!
! Determine the strides which are by construction the maximum upper
! bound of all the derived types.  This is due to the fact that
! there are no 'holes' in the data types: even if one PE does not
! send to any other PEs, it will still have a data type for 'sending'
! data to itself.
!
        Stride_S = 0
        Stride_R = 0       
        DO Ipe=1, GroupSize
          IF ( PatternIn%SendDesc(Ipe)%type /= MPI_DATATYPE_NULL ) THEN
            CALL MPI_TYPE_UB( PatternIn%SendDesc(Ipe)%type, ub, ierror )
            Stride_S = max(Stride_S,ub)
          ENDIF
          IF ( PatternIn%RecvDesc(Ipe)%type /= MPI_DATATYPE_NULL ) THEN
            CALL MPI_TYPE_UB( PatternIn%RecvDesc(Ipe)%type, ub, ierror )
            Stride_R = max(Stride_R,ub)
          ENDIF
        ENDDO

!
! Determine the output data types
!
        DO Ipe=1, GroupSize
          IF ( PatternIn%SendDesc(ipe)%type /= MPI_DATATYPE_NULL ) THEN
            CALL MPI_TYPE_HVECTOR( Mult, 1, Stride_S, PatternIn%SendDesc(Ipe)%type,&
                                   PatternOut%SendDesc(Ipe)%type, Ierror )
            CALL MPI_TYPE_COMMIT( PatternOut%SendDesc(Ipe)%type, Ierror )
          ELSE
            PatternOut%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF
          IF ( PatternIn%RecvDesc(Ipe)%type /= MPI_DATATYPE_NULL ) THEN
            CALL MPI_TYPE_HVECTOR( Mult, 1, Stride_R, PatternIn%RecvDesc(Ipe)%type,&
                                   PatternOut%RecvDesc(Ipe)%type, Ierror )
            CALL MPI_TYPE_COMMIT( PatternOut%RecvDesc(Ipe)%type, Ierror )
          ELSE
            PatternOut%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF
        ENDDO

!
! Determine the stride, which is the sum of all the blocksizes for all
! the derived types (there are no 'holes').
!      
        Stride_S = 0
        Stride_R = 0       
        DO Ipe=1, GroupSize
          Stride_S = Stride_S + sum( PatternIn%SendDesc(ipe)%BlockSizes(:) )
          Stride_R = Stride_R + sum( PatternIn%RecvDesc(ipe)%BlockSizes(:) )
        ENDDO

        DO ipe=1, GroupSize
          Length = SIZE(PatternIn%SendDesc(ipe)%BlockSizes) 
          ALLOCATE( PatternOut%SendDesc(ipe)%Displacements(Length*Mult) )
          ALLOCATE( PatternOut%SendDesc(ipe)%BlockSizes(Length*Mult) )
#if defined( DEBUG_PARPATTERNCOPY )
          write(iulog,*) "Multiplicity", Mult
          write(iulog,*) "Old send blocksizes", PatternIn%SendDesc(ipe)%BlockSizes
#endif
          DO i=1, Length
            Disp = PatternIn%SendDesc(ipe)%Displacements(i)
            DO j=1, Mult
              PatternOut%SendDesc(ipe)%BlockSizes(i+(j-1)*Length) =     &
                    PatternIn%SendDesc(ipe)%BlockSizes(i)
              PatternOut%SendDesc(ipe)%Displacements(i+(j-1)*Length) = Disp
              Disp = Disp + Stride_S
            ENDDO
          ENDDO
          PatternOut%SendDesc(ipe)%Nparcels  = &
            size (PatternOut%SendDesc(ipe)%Displacements)
          PatternOut%SendDesc(ipe)%Tot_Size = &
            sum  (PatternOut%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, PatternOut%SendDesc(ipe)%Nparcels)
#if defined( DEBUG_PARPATTERNCOPY )
          write(iulog,*) "Send blocksizes", PatternOut%SendDesc(ipe)%BlockSizes
          write(iulog,*) "Old recv blocksizes", PatternIn%RecvDesc(ipe)%BlockSizes
#endif
          Length = SIZE(PatternIn%RecvDesc(ipe)%BlockSizes) 
          ALLOCATE( PatternOut%RecvDesc(ipe)%Displacements(Length*Mult) )
          ALLOCATE( PatternOut%RecvDesc(ipe)%BlockSizes(Length*Mult) )
          DO i=1, Length
            Disp = PatternIn%RecvDesc(ipe)%Displacements(i)
            DO j=1, Mult
              PatternOut%RecvDesc(ipe)%BlockSizes(i+(j-1)*Length) =     &
                    PatternIn%RecvDesc(ipe)%BlockSizes(i)
              PatternOut%RecvDesc(ipe)%Displacements(i+(j-1)*Length) = Disp
              Disp = Disp + Stride_R
            ENDDO
          ENDDO
          PatternOut%RecvDesc(ipe)%Nparcels  = &
            size (PatternOut%RecvDesc(ipe)%Displacements)
          PatternOut%RecvDesc(ipe)%Tot_Size = &
            sum  (PatternOut%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, PatternOut%RecvDesc(ipe)%Nparcels)
#if defined( DEBUG_PARPATTERNCOPY )
          write(iulog,*) "Recv blocksizes", PatternOut%RecvDesc(ipe)%BlockSizes
#endif
        ENDDO

        CALL get_partneroffset( InComm, PatternOut%SendDesc, PatternOut%RecvDesc )
      
      CPP_LEAVE_PROCEDURE( "PARPATTERNCOPY" )
      RETURN
!EOC
      END SUBROUTINE ParPatternCopy
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternGhost --- Create pattern for given ghosting
!
! !INTERFACE:
      SUBROUTINE ParPatternGhost( InComm, Ghost, Pattern, mod_method, T )
!
! !USES:
      USE decompmodule, ONLY : DecompGlobalToLocal, DecompLocalToGlobal
      USE ghostmodule, ONLY : GhostType, GhostInfo
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(GhostType),  INTENT( IN )       :: Ghost   ! # of PEs
      INTEGER,  INTENT( IN ), OPTIONAL     :: mod_method ! contiguous or derived type
      INTEGER, INTENT( IN ),  OPTIONAL     :: T       ! 

! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine contructs a communication pattern from the ghost
!     region definition.  That is, the resulting communication pattern
!     can be used in ParBegin/EndTransfer with the ghosted arrays as
!     inputs.  
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE,  MPI_COMM_RANK, MPI_COMM_DUP
!    MPI_TYPE_INDEXED, MPI_TYPE_COMMIT (depending on method)
!
! !REVISION HISTORY:
!   01.02.10   Sawyer     Creation
!   01.06.02   Sawyer     Renamed ParPatternGhost
!   02.06.27   Sawyer     Added data type "T" as optional argument
!   03.03.04   Sawyer     Set partneroffsets field
!   03.11.11   Mirin      Added optional argument mod_method
!
!EOP 
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER  i, j, ipe, pe, Iam, GroupSize, Num, Length, Ptr, Ierror
      INTEGER  Global, End, Local, GlobalSize, LocalSize, BorderSize
      INTEGER  DataType
      INTEGER, ALLOCATABLE :: InVector(:), OutVector(:)
      INTEGER, ALLOCATABLE :: LenInVector(:), LenOutVector(:)
      INTEGER              :: method

      CPP_ENTER_PROCEDURE( "PARPATTERNGHOST" )

      IF (present(T)) THEN
        DataType = T
      ELSE
        DataType = CPP_MPI_REAL8
      ENDIF

      IF (present(mod_method)) THEN
        method = mod_method
      ELSE
        method = 0     ! Default method - see mod_comm for description
      ENDIF
!
! First request the needed ghost values from other processors.
!
      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )

      Pattern%Iam  = Iam
      Pattern%Size = GroupSize

      ALLOCATE( Pattern%SendDesc( GroupSize ) )
      ALLOCATE( Pattern%RecvDesc( GroupSize ) )

      Pattern%SendDesc(:)%method = method
      Pattern%RecvDesc(:)%method = method

!
! Temporary variables
!
      ALLOCATE( LenInVector( GroupSize ) )
      ALLOCATE( LenOutVector( GroupSize ) )

      CALL GhostInfo( Ghost,GroupSize,GlobalSize,LocalSize,BorderSize )
      ALLOCATE( InVector( 2*BorderSize ) )
      ALLOCATE( OutVector( 2*LocalSize ) )

!
! A rather complicated loop to define the local ghost region.
! The concept is the following:  go through all the points in the
! border data structure.   It contains global indices of the points
! which have to be copied over from neighboring PEs.  These indices
! are collected into InVector for transmission to those PEs, in
! effect informing them of the local PEs requirements.
!
! A special case is supported:  if the ghost domain wraps around
! onto the domain of the local PE!  This is very tricky, because
! the index space in both Ghost%Border and Ghost%Local MUST be
! unique for DecompGlobalToLocal to work.   Solution:  ghost 
! points are marked with the negative value of the needed domain 
! value in both Ghost%Border and Ghost%Local.  These are "snapped 
! over" to the true global index with the ABS function, so that 
! they can be subsequently found in the true local domain.
!
      j = 1
      DO ipe=1, GroupSize
        Num = SIZE(Ghost%Border%Head(ipe)%StartTags)
        Length = 0
        DO i = 1, Num
          Global = Ghost%Border%Head(ipe)%StartTags(i)
          IF ( Global /= 0 ) THEN
            Length = Length + 1
            End    = Ghost%Border%Head(ipe)%EndTags(i)
            InVector(j) = ABS(Global)
            InVector(j+1) = ABS(End)
            CALL DecompGlobalToLocal( Ghost%Local, Global, Local, Pe )
            OutVector(Length) = Local-1                ! Zero-based address
            OutVector(Length+Num) = End - Global+1     ! Parcel size
            j = j + 2
          ENDIF
        ENDDO
        LenInVector(ipe) = 2*Length

!
! Set the receive buffer descriptor
!
#if defined(DEBUG_PARPATTERNGHOST)
        write(iulog,*) "Iam",Iam,"Pe",Ipe-1,"Lens",OutVector(Num+1:Num+Length), &
             "Displacements", OutVector(1:Length)
#endif

          IF ( Length > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Length, OutVector(Num+1), OutVector,    &
                                   DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%RecvDesc(ipe)%type = Ptr
          ELSE
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Length) )
          ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Length) )
          DO i=1, Length
            Pattern%RecvDesc(ipe)%Displacements(i) = OutVector(i)
            Pattern%RecvDesc(ipe)%BlockSizes(i)    = OutVector(Num+i)
          ENDDO            
          Pattern%RecvDesc(ipe)%Nparcels  = &
            size (Pattern%RecvDesc(ipe)%Displacements)
          Pattern%RecvDesc(ipe)%Tot_Size = &
            sum  (Pattern%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%RecvDesc(ipe)%Nparcels)

      ENDDO

!
! Everybody exchanges the needed information
!
#if defined(DEBUG_PARPATTERNGHOST)
      write(iulog,*) "iam", iam, "In", LenInVector,                            &
                InVector( 1:SUM(LenInVector) )
#endif
      CALL ParExchangeVectorInt( InComm, LenInVector, InVector,          &
                                     LenOutVector, OutVector )
#if defined(DEBUG_PARPATTERNGHOST)
      write(iulog,*) "iam", iam, "Out", LenOutVector,                          &
                OutVector( 1:SUM(LenOutVector) )
#endif

!
! Now everyone has the segments which need to be sent to the 
! immediate neighbors.  Save these in PatternType.
!
      j = 1
      DO ipe = 1, GroupSize
        Num = LenOutVector(ipe) / 2
        DO i = 1, Num
          CALL DecompGlobalToLocal( Ghost%Local,OutVector(j),Local,pe )
          InVector(i) = Local-1
          InVector(i+Num) = OutVector(j+1) - OutVector(j) + 1
          j = j + 2
        ENDDO
#if defined(DEBUG_PARPATTERNGHOST)
        write(iulog,*) "Iam", Iam, "To", ipe-1, "InVector",                    &
              InVector(1:Num), "block size", InVector(Num+1:2*Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, InVector(Num+1), InVector,         &
                                   DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%SendDesc(ipe)%type = Ptr
          ELSE
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%SendDesc(ipe)%Displacements(i) = InVector(i)
            Pattern%SendDesc(ipe)%BlockSizes(i)    = InVector(Num+i)
          ENDDO            
          Pattern%SendDesc(ipe)%Nparcels  = &
            size (Pattern%SendDesc(ipe)%Displacements)
          Pattern%SendDesc(ipe)%Tot_Size = &
            sum  (Pattern%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%SendDesc(ipe)%Nparcels)

      ENDDO

      CALL get_partneroffset( InComm, Pattern%SendDesc, Pattern%RecvDesc )

!
! Clean up the locally allocate variables
!
      DEALLOCATE( OutVector )
      DEALLOCATE( InVector )
      DEALLOCATE( LenOutVector )
      DEALLOCATE( LenInVector )

      CPP_LEAVE_PROCEDURE( "PARPATTERNGHOST" )
      RETURN
!EOC
      END SUBROUTINE ParPatternGhost
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternDecompToDecomp --- Create pattern between decomps
!
! !INTERFACE:
      SUBROUTINE ParPatternDecompToDecomp( InComm, DA, DB, Pattern, mod_method, T )
!
! !USES:
      USE decompmodule, ONLY : DecompType, DecompGlobalToLocal, DecompInfo
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(DecompType),  INTENT( IN )      :: DA      ! Source Decomp Desc
      TYPE(DecompType),  INTENT( IN )      :: DB      ! Target Decomp Desc
      INTEGER,  INTENT( IN ), OPTIONAL     :: mod_method ! contiguous or derived type
      INTEGER, INTENT( IN ),  OPTIONAL     :: T       ! 

! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine contructs a communication pattern for a 
!     transformation from one decomposition to another, i.e., a 
!     so-called "transpose". The resulting communication pattern 
!     can be used in ParBegin/EndTransfer with the decomposed 
!     arrays as inputs.  
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE,  MPI_COMM_RANK, MPI_COMM_DUP
!    MPI_TYPE_INDEXED, MPI_TYPE_COMMIT (depending on method)
!
! !REVISION HISTORY:
!   01.05.29   Sawyer     Creation from RedistributeCreate
!   01.07.13   Sawyer     Rewritten to minimize DecompGlobalToLocal
!   02.07.16   Sawyer     Added data type T
!   03.11.11   Mirin      Added optional argument mod_method
!   07.03.11   Mirin      Generalized to different sized decompositions
!   07.09.04   Dennis     Reduced amount of temporary memory usage
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER I, J, Tag, Local, Pe, LenB, JB, Ipe, Num, Inc, Off
      INTEGER Ptr                                ! Pointer type
      INTEGER GroupSize, Iam, Ierror, DataType
      INTEGER OldPe, TotalPtsA, NpesA, TotalPtsB, NpesB
      INTEGER              :: method
      INTEGER              :: nCount,maxCount,ierr,sz
      INTEGER              :: lenBjmd,nNeigh,maxLenB,maxNeigh
#ifdef _SMEMORY
      TYPE (ParInfoType) :: Info
#endif

      INTEGER, ALLOCATABLE :: Count(:)           ! # segments for each recv PE
      INTEGER, ALLOCATABLE :: CountOut(:)        ! # segments for each send PE

      INTEGER, ALLOCATABLE :: DisplacementsA(:)  ! Generic displacements
      INTEGER, ALLOCATABLE :: BlockSizesA(:)     ! Generic block sizes
      INTEGER, ALLOCATABLE :: LocalA(:)          ! Generic Local indices

      INTEGER, ALLOCATABLE :: DisplacementsB(:)  ! Displacements for B
      INTEGER, ALLOCATABLE :: BlockSizesB(:)     ! Block sizes for B
      INTEGER, ALLOCATABLE :: LocalB(:)          ! Local indices for B
      INTEGER, ALLOCATABLE :: PeB(:)             ! Processor element numbers

      CPP_ENTER_PROCEDURE( "PARPATTERNDECOMPTODECOMP" )

      IF (present(T)) THEN
        DataType = T
      ELSE
        DataType = CPP_MPI_REAL8
      ENDIF

      IF (present(mod_method)) THEN
        method = mod_method
      ELSE
        method = 0     ! Default method - see mod_comm for description
      ENDIF

! Assume this routine is called by processes [ 0,max(NpesA,NpesB) )

      CALL DecompInfo( DA, NpesA, TotalPtsA )
      CALL DecompInfo( DB, NpesB, TotalPtsB )

      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )

#ifdef _SMEMORY
! Calculate info about the pattern 
      call ParCalcInfo(InComm,DA,DB, Info)
      TotalPtsA=Info%maxNumSeg
      TotalPtsB=Info%maxNumSeg
#endif

      Pattern%Size = GroupSize
      Pattern%Iam  = Iam
!
! Allocate the number of entries and list head arrays
!

!
! Allocate the patterns
!
      ALLOCATE( Pattern%SendDesc( NpesB ) )
      Pattern%SendDesc(:)%method = method
      if (iam .ge. NpesA) then
         do ipe = 1, NpesB
            ALLOCATE( Pattern%SendDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(1) )
            Pattern%SendDesc(ipe)%Tot_Size = -1
            Pattern%SendDesc(ipe)%Nparcels = -1
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%SendDesc(ipe)%Displacements(1) = -1
            Pattern%SendDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

      ALLOCATE( Pattern%RecvDesc( NpesA ) )
      Pattern%RecvDesc(:)%method = method
      if (iam .ge. NpesB) then
         do ipe = 1, NpesA
            ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(1) )
            Pattern%RecvDesc(ipe)%Tot_Size = -1
            Pattern%RecvDesc(ipe)%Nparcels = -1
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%RecvDesc(ipe)%Displacements(1) = -1
            Pattern%RecvDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

!
! Local allocations
!
      ALLOCATE( DisplacementsA( TotalPtsA ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesA( TotalPtsA ) )      ! Allocate for worst case
      ALLOCATE( LocalA( TotalPtsA ) )           ! Allocate for worst case

      ALLOCATE( DisplacementsB( TotalPtsB ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesB( TotalPtsB ) )      ! Allocate for worst case
      ALLOCATE( LocalB( TotalPtsB ) )           ! Allocate for worst case
      ALLOCATE( PeB( TotalPtsB ) )              ! Allocate for worst case

      ALLOCATE( Count( GroupSize ) )
      ALLOCATE( CountOut( GroupSize ) )

      JB        = 0
      Count     = 0
      LenB      = 0
      LocalA      = 0   !  (needed for parexchangevector later)
      BlocksizesA = 0   !  (needed for parexchangevector later)

      Num    = 0
      Inc    = 0

    if (iam .lt. NpesB) then

!
! Parse through all the tags in the local segment
      DO J = 1, SIZE( DB%Head(iam+1)%StartTags )
        OldPe     = -1         ! Set PE undefined
        DO Tag=DB%Head(iam+1)%StartTags(J), DB%Head(iam+1)%EndTags(J)
!
! Determine the index and PE of this entry on A. This might be inlined later
!
          CALL DecompGlobalToLocal( DA, Tag, Local, Pe )

!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
          IF ( Pe /= OldPe ) THEN
            OldPe   = Pe
            IF ( jb > 0 ) THEN
              BlockSizesB(jb) = LenB
              LenB = 0
            ENDIF
            jb = jb+1                     ! increment the segment index
            DisplacementsB(jb) = Inc      ! Zero-based offset of local segment
            LocalB(jb) = Local-1          ! The local index (zero-based)
            PeB(jb) = Pe                  ! Note the ID of the sender
            Count(Pe+1) = Count(Pe+1)+1 ! Increment counter of segments
          ENDIF
          LenB = LenB+1                   ! Good -- segment is getting longer
          Inc = Inc+1                     ! Increment local index
        ENDDO
      ENDDO
!
! Clean up
!
      IF ( jb>0 ) BlockSizesB(jb) = LenB
#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)
      write(iulog,*) iam, "BlockSizes", BlockSizesB(1:jb), DisplacementsB(1:jb), PeB(1:jb), Count
#endif

      CPP_ASSERT_F90( JB .LE. TotalPtsB )
!
! Now create the pattern from the displacements and block sizes
!
      Inc = 0
      DO ipe = 1, NpesA
!
! Find the segments which are relevant for the sender ipe
! Make compact arrays BlockSizes and Displacements 
!
        DO j = 1, jb
          IF ( PeB(j) == ipe-1 ) THEN
            Inc = Inc + 1
            BlockSizesA(Inc) = BlockSizesB(j)
            DisplacementsA(Inc) = DisplacementsB(j)
            LocalA(Inc)      = LocalB(j)
          ENDIF
        ENDDO
      ENDDO
      CPP_ASSERT_F90( Inc .LE. TotalPtsA )

!
! Create the receiver communication pattern
!
      Off = 0
      DO ipe = 1, NpesA
        Num = Count(ipe)
        if(Num >0) then 
#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)
        write(iulog,*) "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num,         &
                 "Displacements", DisplacementsA(Off+1:Off+Num),        &
                 "BlockSizes", BlockSizesA(Off+1:Off+Num)
#endif
        endif
          IF ( Num > 0 .and. method > 0 ) THEN

            CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),             &
                                   DisplacementsA(Off+1),               &
                                   DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%RecvDesc(ipe)%type = Ptr
          ELSE
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)
            Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)
          ENDDO
          Pattern%RecvDesc(ipe)%Nparcels  = &
            size (Pattern%RecvDesc(ipe)%Displacements)
          Pattern%RecvDesc(ipe)%Tot_Size = &
            sum  (Pattern%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%RecvDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesB)

!
! Now communicate what the receiver is expecting from the sender
!
      CALL ParExchangeVectorInt( InComm, Count, LocalA,                 &
                                 CountOut, DisplacementsB  )
      CALL ParExchangeVectorInt( InComm, Count, BlockSizesA,            &
                                 CountOut, BlockSizesB )

!
! Sender A: BlockSizes and Displacements can now be stored
!

    if (iam .lt. NpesA) then

      Off = 0
      DO ipe=1, NpesB
        Num = CountOut(ipe)
        if(Num>0) then 
#if defined(DEBUG_PARPATTERNDECOMPTODECOMP)
        write(iulog,*) "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,           &
                 "Displacements", DisplacementsB(Off+1:Off+Num),        &
                 "BlockSizes", BlockSizesB(Off+1:Off+Num)
#endif
        endif
          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1),             &
                                   DisplacementsB(Off+1),               &
                                   DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%SendDesc(ipe)%type = Ptr
          ELSE
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)
            Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)
          ENDDO
          Pattern%SendDesc(ipe)%Nparcels  =  &
            size (Pattern%SendDesc(ipe)%Displacements)
          Pattern%SendDesc(ipe)%Tot_Size = &
            sum  (Pattern%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%SendDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesA)

      CALL get_partneroffset( InComm, Pattern%SendDesc, Pattern%RecvDesc )
      
      DEALLOCATE( CountOut )
      DEALLOCATE( Count )

      DEALLOCATE( PeB )
      DEALLOCATE( LocalB )
      DEALLOCATE( BlockSizesB )
      DEALLOCATE( DisplacementsB )

      DEALLOCATE( LocalA )
      DEALLOCATE( BlockSizesA )
      DEALLOCATE( DisplacementsA )

      CPP_LEAVE_PROCEDURE( "PARPATTERNDECOMPTODECOMP" )
      RETURN
!EOC
      END SUBROUTINE ParPatternDecompToDecomp
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternDecompToGhost --- Create pattern decomp to ghost
!
! !INTERFACE:
      SUBROUTINE ParPatternDecompToGhost( InComm, DA, GB, Pattern, mod_method, T )
!
! !USES:
      USE decompmodule, ONLY : DecompType, DecompGlobalToLocal,         &
                               DecompInfo
      USE ghostmodule, ONLY : GhostType, GhostInfo
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(DecompType),  INTENT( IN )      :: DA      ! Source Ghost Desc
      TYPE(GhostType),  INTENT( IN )       :: GB      ! Target Ghost Desc
      INTEGER,  INTENT( IN ), OPTIONAL     :: mod_method ! contiguous or derived type
      INTEGER, INTENT( IN ),  OPTIONAL     :: T       !

! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine contructs a communication pattern for a transformation
!     from decomposition to a ghosted decomposition, i.e., a so-called 
!     "transpose".  The resulting communication pattern can be used in 
!     ParBegin/EndTransfer with the decomposed arrays as inputs.  
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE,  MPI_COMM_RANK, MPI_COMM_DUP
!    MPI_TYPE_INDEXED, MPI_TYPE_COMMIT (depending on method)
!
! !REVISION HISTORY:
!   01.07.12   Sawyer     Creation from ParPatternDecompToDecomp
!   02.03.20   Sawyer     Bug fix: added OldLocal, increment Off
!   02.07.16   Sawyer     Added data type T
!   03.11.11   Mirin      Added optional argument mod_method
!   07.03.11   Mirin      Generalized to different sized decompositions
!   07.09.04   Dennis     Reduced amount of temporary memory usage
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER I, J, Tag, Local, Pe, LenB, JB, Ipe, Num, Inc, Off
      INTEGER Ptr                                ! Pointer type
      INTEGER GroupSize, Iam, Ierror
      INTEGER OldPe, OldLocal, TotalPtsA, NpesA
      INTEGER GlobalSizeB, LocalSizeB, BorderSizeB, NpesB
      INTEGER DataType
      INTEGER              :: method
      INTEGER              :: nCount, maxCount, ierr
#ifdef _SMEMORY
      TYPE (ParInfoType) :: Info
#endif

      INTEGER, ALLOCATABLE :: Count(:)           ! # segments for each recv PE
      INTEGER, ALLOCATABLE :: CountOut(:)        ! # segments for each send PE

      INTEGER, ALLOCATABLE :: DisplacementsA(:)  ! Generic displacements
      INTEGER, ALLOCATABLE :: BlockSizesA(:)     ! Generic block sizes
      INTEGER, ALLOCATABLE :: LocalA(:)          ! Generic Local indices

      INTEGER, ALLOCATABLE :: DisplacementsB(:)  ! Displacements for B
      INTEGER, ALLOCATABLE :: BlockSizesB(:)     ! Block sizes for B
      INTEGER, ALLOCATABLE :: LocalB(:)          ! Local indices for B
      INTEGER, ALLOCATABLE :: PeB(:)             ! Processor element numbers

      CPP_ENTER_PROCEDURE( "PARPATTERNDECOMPTOGHOST" )

      IF (present(T)) THEN
        DataType = T
      ELSE
        DataType = CPP_MPI_REAL8
      ENDIF

      IF (present(mod_method)) THEN
        method = mod_method
      ELSE
        method = 0     ! Default method - see mod_comm for description
      ENDIF

! Assume this routine is called by processes [ 0,max(NpesA,NpesB) )

      CALL DecompInfo( DA, NpesA, TotalPtsA )
      CALL GhostInfo( GB, NpesB, GlobalSizeB, LocalSizeB, BorderSizeB )

      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )

#ifdef _SMEMORY
! Calculate info about the pattern 
      call ParCalcInfo(InComm,DA,GB, Info)
      TotalPtsA=Info%maxNumSeg
      GlobalSizeB=Info%maxNumSeg
#endif

      Pattern%Size = GroupSize
      Pattern%Iam  = Iam
!
! Allocate the number of entries and list head arrays
!

!
! Allocate the patterns
!
      ALLOCATE( Pattern%SendDesc( NpesB ) )
      Pattern%SendDesc(:)%method = method
      if (iam .ge. NpesA) then
         do ipe = 1, NpesB
            ALLOCATE( Pattern%SendDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(1) )
            Pattern%SendDesc(ipe)%Tot_Size = -1
            Pattern%SendDesc(ipe)%Nparcels = -1
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%SendDesc(ipe)%Displacements(1) = -1
            Pattern%SendDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

      ALLOCATE( Pattern%RecvDesc( NpesA ) )
      Pattern%RecvDesc(:)%method = method
      if (iam .ge. NpesB) then
         do ipe = 1, NpesA
            ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(1) )
            Pattern%RecvDesc(ipe)%Tot_Size = -1
            Pattern%RecvDesc(ipe)%Nparcels = -1
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%RecvDesc(ipe)%Displacements(1) = -1
            Pattern%RecvDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

!
! Local allocations
!
      ALLOCATE( DisplacementsA( TotalPtsA ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesA( TotalPtsA ) )      ! Allocate for worst case
      ALLOCATE( LocalA( TotalPtsA ) )           ! Allocate for worst case

      ALLOCATE( DisplacementsB( GlobalSizeB ) ) ! Allocate for worst case
      ALLOCATE( BlockSizesB( GlobalSizeB ) )    ! Allocate for worst case
      ALLOCATE( LocalB( GlobalSizeB ) )         ! Allocate for worst case
      ALLOCATE( PeB( GlobalSizeB ) )            ! Allocate for worst case

      ALLOCATE( Count( GroupSize ) )
      ALLOCATE( CountOut( GroupSize ) )

      JB        = 0
      Count     = 0
      LenB      = 0
      LocalA      = 0   !  (needed for parexchangevector later)
      BlocksizesA = 0   !  (needed for parexchangevector later)

      Num    = 0
      Inc    = 0

    if (iam .lt. NpesB) then

!
! Parse through all the tags in the local segment
      DO J = 1, SIZE( GB%Local%Head(iam+1)%StartTags )
        OldPe     = -1         ! Set PE undefined
        OldLocal  =  0         ! Set local index undefined
        DO Tag=GB%Local%Head(iam+1)%StartTags(J),                         &
                GB%Local%Head(iam+1)%EndTags(J)
          IF ( Tag > 0 ) THEN        ! Active point
!
! Determine the index and PE of this entry on A. This might be inlined later
!
            CALL DecompGlobalToLocal( DA, Tag, Local, Pe )

!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
            IF ( Pe /= OldPe .OR. Local /= OldLocal+1 ) THEN
              IF ( jb > 0 ) THEN
                BlockSizesB(jb) = LenB
                LenB = 0
              ENDIF
              jb = jb+1                     ! increment the segment index
              DisplacementsB(jb) = Inc      ! Zero-based offset of local segment
              LocalB(jb) = Local-1          ! Local indices (zero-based)
              PeB(jb) = Pe                  ! Note the ID of the sender
              Count(Pe+1) = Count(Pe+1)+1 ! Increment counter of segments
            ENDIF
            OldPe   = Pe                    ! Update PE
            OldLocal= Local                 ! Update local index
            LenB = LenB+1                   ! Good -- segment is getting longer
          ENDIF
          Inc = Inc+1                     ! Increment local index
        ENDDO
      ENDDO
!
! Clean up
!
      IF ( jb>0 ) BlockSizesB(jb) = LenB

      CPP_ASSERT_F90( JB .LE. GlobalSize )
!
! Now create the pattern from the displacements and block sizes
!
      Inc = 0
      DO ipe = 1, NpesA
!
! Find the segments which are relevant for the sender ipe
! Make compact arrays BlockSizes and Displacements 
!
        DO j = 1, jb
          IF ( PeB(j) == ipe-1 ) THEN
            Inc = Inc + 1
            BlockSizesA(Inc) = BlockSizesB(j)
            DisplacementsA(Inc) = DisplacementsB(j)
            LocalA(Inc)      = LocalB(j)
          ENDIF
        ENDDO
      ENDDO

      CPP_ASSERT_F90( Inc .LE. TotalPtsA )

      Off = 0
      DO ipe = 1, NpesA
        Num = Count(ipe)
#if defined( DEBUG_PARPATTERNDECOMPTOGHOST )
        write(iulog,*) "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num, &
                 "Displacements", DisplacementsA(Off+1:Off+Num), &
                 "BlockSizes", BlockSizesA(Off+1:Off+Num)
#endif

!
! Create the receiver communication pattern
!
          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),        &
                   DisplacementsA(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%RecvDesc(ipe)%type = Ptr
          ELSE
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)
            Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)
          ENDDO
          Pattern%RecvDesc(ipe)%Nparcels  = &
            size (Pattern%RecvDesc(ipe)%Displacements)
          Pattern%RecvDesc(ipe)%Tot_Size = &
            sum  (Pattern%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%RecvDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesB)

!
! Now communicate what the receiver is expecting to the sender
!
      CALL ParExchangeVectorInt( InComm, Count, LocalA,                 &
                                 CountOut, DisplacementsB  )
      CALL ParExchangeVectorInt( InComm, Count, BlockSizesA,            &
                                 CountOut, BlockSizesB )

!
! Sender A: BlockSizes and Displacements can now be stored
!

    if (iam .lt. NpesA) then

      Off = 0
      DO ipe=1, NpesB
        Num = CountOut(ipe)
#if defined( DEBUG_PARPATTERNDECOMPTOGHOST )
        write(iulog,*) "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,           &
                 "Displacements", DisplacementsB(Off+1:Off+Num),        &
                 "BlockSizes", BlockSizesB(Off+1:Off+Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1),          &
                    DisplacementsB(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%SendDesc(ipe)%type = Ptr
          ELSE
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)
            Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)
          ENDDO
          Pattern%SendDesc(ipe)%Nparcels  = &
            size (Pattern%SendDesc(ipe)%Displacements)
          Pattern%SendDesc(ipe)%Tot_Size = &
            sum  (Pattern%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%SendDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesA)

      CALL get_partneroffset( InComm, Pattern%SendDesc, Pattern%RecvDesc )
      
      DEALLOCATE( CountOut )
      DEALLOCATE( Count )

      DEALLOCATE( PeB )
      DEALLOCATE( LocalB )
      DEALLOCATE( BlockSizesB )
      DEALLOCATE( DisplacementsB )

      DEALLOCATE( LocalA )
      DEALLOCATE( BlockSizesA )
      DEALLOCATE( DisplacementsA )

      CPP_LEAVE_PROCEDURE( "PARPATTERNDECOMPTOGHOST" )
      RETURN
!EOC
      END SUBROUTINE ParPatternDecompToGhost
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternGhostToDecomp --- Create pattern between decomps
!
! !INTERFACE:
      SUBROUTINE ParPatternGhostToDecomp( InComm, GA, DB, Pattern, mod_method, T )
!
! !USES:
      USE decompmodule, ONLY : DecompType, DecompGlobalToLocal, DecompInfo
      USE ghostmodule, ONLY : GhostType, GhostInfo
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(GhostType),   INTENT( IN )      :: GA      ! Source Decomp Desc
      TYPE(DecompType),  INTENT( IN )      :: DB      ! Target Decomp Desc
      INTEGER,  INTENT( IN ), OPTIONAL     :: mod_method ! contiguous or derived type
      INTEGER, INTENT( IN ),  OPTIONAL     :: T       !
! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine contructs a communication pattern for a 
!     transformation from one ghosted decomposition to partitioned
!     one, i.e., a so-called "transpose". The resulting communication 
!     pattern can be used in ParBegin/EndTransfer with the decomposed 
!     arrays as inputs.  
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE,  MPI_COMM_RANK, MPI_COMM_DUP
!    MPI_TYPE_INDEXED, MPI_TYPE_COMMIT (depending on method)
!
! !REVISION HISTORY:
!   02.01.10   Sawyer     Creation from DecompToDecomp
!   02.07.16   Sawyer     Added data type T
!   03.11.11   Mirin      Added optional argument mod_method
!   07.03.11   Mirin      Generalized to different sized decompositions
!   07.09.04   Dennis     Reduced amount of temporary memory usage
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER I, J, Tag, Local, Pe, Len, JA, Ipe, Num, Inc, Off
      INTEGER NpesA, GlobalSizeA, LocalSizeA, BorderSizeA
      INTEGER OldPe, OldLocal, TotalPtsB, NpesB
      INTEGER GroupSize, Iam, Ierror
      INTEGER Ptr                                ! Pointer type
      INTEGER  DataType
      INTEGER              :: method
      INTEGER              :: nCount, maxCount, ierr
#ifdef _SMEMORY
      TYPE (ParInfoType) :: Info
#endif

      INTEGER, ALLOCATABLE :: Count(:)           ! # segments for each recv PE
      INTEGER, ALLOCATABLE :: CountOut(:)        ! # segments for each send PE

      INTEGER, ALLOCATABLE :: DisplacementsA(:)  ! Generic displacements
      INTEGER, ALLOCATABLE :: BlockSizesA(:)     ! Generic block sizes
      INTEGER, ALLOCATABLE :: GlobalA(:)          ! Generic Local indices
      INTEGER, ALLOCATABLE :: PeA(:)             ! Processor element numbers

      INTEGER, ALLOCATABLE :: DisplacementsB(:)  ! Displacements for B
      INTEGER, ALLOCATABLE :: BlockSizesB(:)     ! Block sizes for B
      INTEGER, ALLOCATABLE :: GlobalB(:)         ! Global indices for B

      CPP_ENTER_PROCEDURE( "PARPATTERNGHOSTTODECOMP" )

      IF (present(T)) THEN
        DataType = T
      ELSE
        DataType = CPP_MPI_REAL8
      ENDIF

      IF (present(mod_method)) THEN
        method = mod_method
      ELSE
        method = 0     ! Default method - see mod_comm for description
      ENDIF

! Assume this routine is called by processes [ 0,max(NpesA,NpesB) )

      CALL GhostInfo( GA, NpesA, GlobalSizeA, LocalSizeA, BorderSizeA )
      CALL DecompInfo( DB, NpesB, TotalPtsB )

      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )

#ifdef _SMEMORY
! Calculate info about the pattern 
      call ParCalcInfo(InComm,GA,DB, Info)
      GlobalSizeA=Info%maxNumSeg
      TotalPtsB=Info%maxNumSeg
#endif

      Pattern%Size = GroupSize
      Pattern%Iam  = Iam
!
! Allocate the number of entries and list head arrays
!

!
! Allocate the patterns
!
      ALLOCATE( Pattern%SendDesc( NpesB ) )
      Pattern%SendDesc(:)%method = method
      if (iam .ge. NpesA) then
         do ipe = 1, NpesB
            ALLOCATE( Pattern%SendDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(1) )
            Pattern%SendDesc(ipe)%Tot_Size = -1
            Pattern%SendDesc(ipe)%Nparcels = -1
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%SendDesc(ipe)%Displacements(1) = -1
            Pattern%SendDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

      ALLOCATE( Pattern%RecvDesc( NpesA ) )
      Pattern%RecvDesc(:)%method = method
      if (iam .ge. NpesB) then
         do ipe = 1, NpesA
            ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(1) )
            Pattern%RecvDesc(ipe)%Tot_Size = -1
            Pattern%RecvDesc(ipe)%Nparcels = -1
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%RecvDesc(ipe)%Displacements(1) = -1
            Pattern%RecvDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

!
! Local allocations
!
      ALLOCATE( DisplacementsA( GlobalSizeA ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesA( GlobalSizeA ) )      ! Allocate for worst case
      ALLOCATE( GlobalA( GlobalSizeA ) )          ! Allocate for worst case
      ALLOCATE( PeA( GlobalSizeA ) )              ! Allocate for worst case

      ALLOCATE( DisplacementsB( TotalPtsB ) )     ! Allocate for worst case
      ALLOCATE( BlockSizesB( TotalPtsB ) )        ! Allocate for worst case
      ALLOCATE( GlobalB( TotalPtsB ) )            ! Allocate for worst case

      ALLOCATE( Count( GroupSize ) )
      ALLOCATE( CountOut( GroupSize ) )

      JA     = 0
      Count  = 0
      Len    = 0
      GlobalB     = 0   !  (needed for parexchangevector later)
      BlockSizesB = 0   !  (needed for parexchangevector later)

      Num    = 0
      Inc    = 0

    if (iam .lt. NpesB) then

!
! Parse through all the tags in the local segment
      DO J = 1, SIZE( DB%Head(iam+1)%StartTags )
        OldPe     = -1         ! Set PE undefined
        OldLocal  = 0          ! Set index value undefined
        DO Tag=DB%Head(iam+1)%StartTags(J), DB%Head(iam+1)%EndTags(J)
!
! Determine the index and PE of this entry on A. This might be inlined later
!
          CALL DecompGlobalToLocal( GA%Decomp, Tag, Local, Pe )

!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
          IF ( Pe /= OldPe  .OR. Local /= OldLocal+1 ) THEN
            IF ( ja > 0 ) THEN
              BlockSizesA(ja) = Len
              Len = 0
            ENDIF
            ja = ja+1                     ! increment the segment index
            DisplacementsA(ja) = Inc      ! Zero-based offset of local segment
            GlobalA(ja) = Tag             ! The global tag of the desired datum
            PeA(ja) = Pe                  ! Note the ID of the sender
            Count(Pe+1) = Count(Pe+1)+1   ! Increment counter of segments
          ENDIF
          OldPe    = Pe                   ! Update old PE
          OldLocal = Local                ! Update old local index
          Len = Len+1                     ! Good -- segment is getting longer
          Inc = Inc+1                     ! Increment local index
        ENDDO
      ENDDO
!
! Clean up
!
      BlockSizesA(ja) = Len
      CPP_ASSERT_F90( JA .LE. GlobalSizeA )
!
! Now create the pattern from the displacements and block sizes
!
      Inc = 0
      DO ipe = 1, NpesA
!
! Find the segments which are relevant for the sender ipe
! Make compact arrays BlockSizes and Displacements 
!
        DO j = 1, ja
          IF ( PeA(j) == ipe-1 ) THEN
            Inc = Inc + 1
            BlockSizesB(Inc) = BlockSizesA(j)
            DisplacementsB(Inc) = DisplacementsA(j)
            GlobalB(Inc)      = GlobalA(j)
          ENDIF
        ENDDO
      ENDDO

     CPP_ASSERT_F90(Inc .LE. TotalPtsB)

!
! Create the receiver communication pattern
!
      Off = 0
      DO ipe = 1, NpesA
        Num = Count(ipe)
#if defined( DEBUG_PARPATTERNGHOSTTODECOMP )
        write(iulog,*) "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num, &
                 "Displacements", DisplacementsB(Off+1:Off+Num), &
                 "BlockSizes", BlockSizesB(Off+1:Off+Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1),       &
               DisplacementsB(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%RecvDesc(ipe)%type = Ptr
          ELSE
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)
            Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)
          ENDDO
          Pattern%RecvDesc(ipe)%Nparcels  = &
            size (Pattern%RecvDesc(ipe)%Displacements)
          Pattern%RecvDesc(ipe)%Tot_Size = &
            sum  (Pattern%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%RecvDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesB)

!
! Now communicate what the receiver is expecting to the sender
!
      CALL ParExchangeVectorInt( InComm, Count, GlobalB,                 &
                                 CountOut, GlobalA  )
      CALL ParExchangeVectorInt( InComm, Count, BlockSizesB,            &
                                 CountOut, BlockSizesA )

    if (iam .lt. NpesA) then

!
! Sender A: BlockSizes and Displacements can now be stored
!
      Off = 0
      DO ipe=1, NpesB
        Num = CountOut(ipe)
        DO i=1, Num
          CALL DecompGlobalToLocal( GA%Local, GlobalA(i+Off), Local, Pe )
          DisplacementsA(i+Off) = Local-1    ! zero-based displacement
        ENDDO
#if defined( DEBUG_PARPATTERNGHOSTTODECOMP )
        write(iulog,*) "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,  &
                 "Displacements", DisplacementsA(Off+1:Off+Num), &
                 "BlockSizes", BlockSizesA(Off+1:Off+Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),        &
                    DisplacementsA(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%SendDesc(ipe)%type = Ptr
          ELSE
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)
            Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)
          ENDDO
          Pattern%SendDesc(ipe)%Nparcels  = &
            size (Pattern%SendDesc(ipe)%Displacements)
          Pattern%SendDesc(ipe)%Tot_Size = &
            sum  (Pattern%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%SendDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesA)

      CALL get_partneroffset( InComm, Pattern%SendDesc, Pattern%RecvDesc )
      
      DEALLOCATE( CountOut )
      DEALLOCATE( Count )

      DEALLOCATE( PeA )
      DEALLOCATE( GlobalA )
      DEALLOCATE( BlockSizesA )
      DEALLOCATE( DisplacementsA )

      DEALLOCATE( GlobalB )
      DEALLOCATE( BlockSizesB )
      DEALLOCATE( DisplacementsB )

      CPP_LEAVE_PROCEDURE( "PARPATTERNGHOSTTODECOMP" )
      RETURN
!EOC
      END SUBROUTINE ParPatternGhostToDecomp
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternGhostToGhost --- Create pattern between decomps
!
! !INTERFACE:
      SUBROUTINE ParPatternGhostToGhost( InComm, GA, GB, Pattern, mod_method, T )
!
! !USES:
      USE decompmodule, ONLY : DecompGlobalToLocal
      USE ghostmodule, ONLY : GhostType, GhostInfo
      USE mod_comm, ONLY : get_partneroffset
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )               :: InComm  ! # of PEs
      TYPE(GhostType),   INTENT( IN )      :: GA      ! Source Ghost Decomp
      TYPE(GhostType),   INTENT( IN )      :: GB      ! Target Ghost Decomp
      INTEGER,  INTENT( IN ), OPTIONAL     :: mod_method ! contiguous or derived type
      INTEGER, INTENT( IN ),  OPTIONAL     :: T       !
! !OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( OUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine contructs a communication pattern for a 
!     transformation from one ghosted decomposition to partitioned
!     one, i.e., a so-called "transpose". The resulting communication 
!     pattern can be used in ParBegin/EndTransfer with the decomposed 
!     arrays as inputs.  
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE,  MPI_COMM_RANK, MPI_COMM_DUP
!    MPI_TYPE_INDEXED, MPI_TYPE_COMMIT (depending on method)
!
! !REVISION HISTORY:
!   02.01.10   Sawyer     Creation from DecompToDecomp
!   02.07.16   Sawyer     Added data type T
!   03.11.11   Mirin      Added optional argument mod_method
!   07.03.11   Mirin      Generalized to different sized decompositions
!   07.09.04   Dennis     Reduced amount of temporary memory usage
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER I, J, Tag, Local, Pe, Len, JA, Ipe, Num, Inc, Off
      INTEGER NpesA, GlobalSizeA, LocalSizeA, BorderSizeA
      INTEGER NpesB, GlobalSizeB, LocalSizeB, BorderSizeB
      INTEGER GroupSize, Iam, Ierror, OldPe, OldLocal 
      INTEGER Ptr                                ! Pointer type
      INTEGER  DataType
      INTEGER              :: method
      INTEGER              :: nCount, maxCount, ierr
#ifdef _SMEMORY
      TYPE (ParInfoType) :: Info
#endif

      INTEGER, ALLOCATABLE :: Count(:)           ! # segments for each recv PE
      INTEGER, ALLOCATABLE :: CountOut(:)        ! # segments for each send PE

      INTEGER, ALLOCATABLE :: DisplacementsA(:)  ! Generic displacements
      INTEGER, ALLOCATABLE :: BlockSizesA(:)     ! Generic block sizes
      INTEGER, ALLOCATABLE :: GlobalA(:)         ! Generic Local indices
      INTEGER, ALLOCATABLE :: PeA(:)             ! Processor element numbers

      INTEGER, ALLOCATABLE :: DisplacementsB(:)  ! Displacements for B
      INTEGER, ALLOCATABLE :: BlockSizesB(:)     ! Block sizes for B
      INTEGER, ALLOCATABLE :: GlobalB(:)         ! Global indices for B

      CPP_ENTER_PROCEDURE( "PARPATTERNGHOSTTOGHOST" )

      IF (present(T)) THEN
        DataType = T
      ELSE
        DataType = CPP_MPI_REAL8
      ENDIF

      IF (present(mod_method)) THEN
        method = mod_method
      ELSE
        method = 0     ! Default method - see mod_comm for description
      ENDIF

! Assume this routine is called by processes [ 0,max(NpesA,NpesB) )

      CALL GhostInfo( GA, NpesA, GlobalSizeA, LocalSizeA, BorderSizeA )
      CALL GhostInfo( GB, NpesB, GlobalSizeB, LocalSizeB, BorderSizeB )

      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_DUP( InComm, Pattern%Comm, Ierror )

#ifdef _SMEMORY
! Calculate info about the pattern 
      call ParCalcInfo(InComm,GA,GB, Info)
      GlobalSizeA=Info%maxNumSeg
      GlobalSizeB=Info%maxNumSeg
#endif

      Pattern%Size = GroupSize
      Pattern%Iam  = Iam
!
! Allocate the number of entries and list head arrays
!

!
! Allocate the patterns
!
      ALLOCATE( Pattern%SendDesc( NpesB ) )
      Pattern%SendDesc(:)%method = method
      if (iam .ge. NpesA) then
         do ipe = 1, NpesB
            ALLOCATE( Pattern%SendDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(1) )
            Pattern%SendDesc(ipe)%Tot_Size = -1
            Pattern%SendDesc(ipe)%Nparcels = -1
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%SendDesc(ipe)%Displacements(1) = -1
            Pattern%SendDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

      ALLOCATE( Pattern%RecvDesc( NpesA ) )
      Pattern%RecvDesc(:)%method = method
      if (iam .ge. NpesB) then
         do ipe = 1, NpesA
            ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(1) )
            ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(1) )
            Pattern%RecvDesc(ipe)%Tot_Size = -1
            Pattern%RecvDesc(ipe)%Nparcels = -1
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
            Pattern%RecvDesc(ipe)%Displacements(1) = -1
            Pattern%RecvDesc(ipe)%Blocksizes(1) = -1
         enddo
      endif

!
! Local allocations
!
      ALLOCATE( DisplacementsA( GlobalSizeA ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesA( GlobalSizeA ) )      ! Allocate for worst case
      ALLOCATE( GlobalA( GlobalSizeA ) )          ! Allocate for worst case
      ALLOCATE( PeA( GlobalSizeA ) )              ! Allocate for worst case

      ALLOCATE( DisplacementsB( GlobalSizeB ) )   ! Allocate for worst case
      ALLOCATE( BlockSizesB( GlobalSizeB ) )      ! Allocate for worst case
      ALLOCATE( GlobalB( GlobalSizeB ) )          ! Allocate for worst case

      ALLOCATE( Count( GroupSize ) )
      ALLOCATE( CountOut( GroupSize ) )

      JA        = 0
      Count     = 0
      Len      = 0
      GlobalB     = 0   !  (needed for parexchangevector later)
      BlocksizesB = 0   !  (needed for parexchangevector later)

      Num    = 0
      Inc    = 0

    if (iam .lt. NpesB) then

!
! Parse through all the tags in the local segment
      DO J = 1, SIZE( GB%Local%Head(iam+1)%StartTags )
        OldPe     = -1         ! Set PE undefined
        OldLocal  = 0          ! Set index value undefined
        DO Tag=GB%Local%Head(iam+1)%StartTags(J), GB%Local%Head(iam+1)%EndTags(J)
          IF ( Tag > 0 ) THEN       ! Active point
!
! Determine the index and PE of this entry on A. This might be inlined later
!
            CALL DecompGlobalToLocal( GA%Decomp, Tag, Local, Pe )
!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
            IF ( Pe /= OldPe  .OR. Local /= OldLocal+1 ) THEN
              IF ( ja > 0 ) THEN
                BlockSizesA(ja) = Len
                Len = 0
              ENDIF
              ja = ja+1                     ! increment the segment index
              DisplacementsA(ja) = Inc      ! Zero-based offset of local segment
              GlobalA(ja) = Tag             ! The global tag of the desired datum
              PeA(ja) = Pe                  ! Note the ID of the sender
              Count(Pe+1) = Count(Pe+1)+1   ! Increment counter of segments
            ENDIF
            OldPe   = Pe                    ! Update old PE
            OldLocal = Local                ! Update old local index
            Len = Len+1                     ! Good -- segment is getting longer
          ENDIF
          Inc = Inc+1                       ! Increment local index
        ENDDO
      ENDDO
!
! Clean up
!
      BlockSizesA(ja) = Len

      CPP_ASSERT_F90( JA .LE. GlobalSizeA )

!
! Now create the pattern from the displacements and block sizes
!
      Inc = 0
      DO ipe = 1, NpesA
!
! Find the segments which are relevant for the sender ipe
! Make compact arrays BlockSizes and Displacements 
!
        DO j = 1, ja
          IF ( PeA(j) == ipe-1 ) THEN
            Inc = Inc + 1
            BlockSizesB(Inc) = BlockSizesA(j)
            DisplacementsB(Inc) = DisplacementsA(j)
            GlobalB(Inc)      = GlobalA(j)
          ENDIF
        ENDDO
      ENDDO
      CPP_ASSERT_F90( Inc .LE. GlobalSizeB )

!
! Create the receiver communication pattern
!
      Off = 0
      DO ipe = 1, NpesA
        Num = Count(ipe)
#if defined(DEBUG_PARPATTERNGHOSTTOGHOST)
        write(iulog,*) "Receiver Iam", Iam, "Ipe", Ipe-1, "Num", Num, &
                 "Displacements", DisplacementsB(Off+1:Off+Num), &
                 "BlockSizes", BlockSizesB(Off+1:Off+Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesB(Off+1),         &
                 DisplacementsB(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%RecvDesc(ipe)%type = Ptr
          ELSE
            Pattern%RecvDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%RecvDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%RecvDesc(ipe)%Displacements(i) = DisplacementsB(i+Off)
            Pattern%RecvDesc(ipe)%BlockSizes(i)    = BlockSizesB(i+Off)
          ENDDO
          Pattern%RecvDesc(ipe)%Nparcels  = &
            size (Pattern%RecvDesc(ipe)%Displacements)
          Pattern%RecvDesc(ipe)%Tot_Size = &
            sum  (Pattern%RecvDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%RecvDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesB)

!
! Now communicate what the receiver is expecting to the sender
!
      CALL ParExchangeVectorInt( InComm, Count, GlobalB,                &
                                 CountOut, GlobalA  )
      CALL ParExchangeVectorInt( InComm, Count, BlockSizesB,            &
                                 CountOut, BlockSizesA )

    if (iam .lt. NpesA) then

!
! Sender A: BlockSizes and Displacements can now be stored
!
      Off = 0
      DO ipe=1, NpesB
        Num = CountOut(ipe)
        DO i=1, Num
          CALL DecompGlobalToLocal( GA%Local, GlobalA(i+Off), Local, Pe )
          DisplacementsA(i+Off) = Local-1    ! zero-based displacement
        ENDDO
#if defined(DEBUG_PARPATTERNGHOSTTOGHOST)
        write(iulog,*) "Sender Iam", Iam, "Ipe", Ipe-1, "Num", Num,  &
                 "Displacements", DisplacementsA(Off+1:Off+Num), &
                 "BlockSizes", BlockSizesA(Off+1:Off+Num)
#endif

          IF ( Num > 0 .and. method > 0 ) THEN
            CALL MPI_TYPE_INDEXED( Num, BlockSizesA(Off+1),        &
                 DisplacementsA(Off+1), DataType, Ptr, Ierror )
            CALL MPI_TYPE_COMMIT( Ptr, Ierror )
            Pattern%SendDesc(ipe)%type = Ptr
          ELSE
            Pattern%SendDesc(ipe)%type = MPI_DATATYPE_NULL
          ENDIF

          ALLOCATE( Pattern%SendDesc(ipe)%Displacements(Num) )
          ALLOCATE( Pattern%SendDesc(ipe)%BlockSizes(Num) )
          DO i=1, Num
            Pattern%SendDesc(ipe)%Displacements(i) = DisplacementsA(i+Off)
            Pattern%SendDesc(ipe)%BlockSizes(i)    = BlockSizesA(i+Off)
          ENDDO
          Pattern%SendDesc(ipe)%Nparcels  = &
            size (Pattern%SendDesc(ipe)%Displacements)
          Pattern%SendDesc(ipe)%Tot_Size = &
            sum  (Pattern%SendDesc(ipe)%Blocksizes)
          Max_Nparcels = max (Max_Nparcels, Pattern%SendDesc(ipe)%Nparcels)

        Off = Off + Num
      ENDDO

    endif !  (iam .lt. NpesA)

      CALL get_partneroffset( InComm, Pattern%SendDesc, Pattern%RecvDesc )


      DEALLOCATE( CountOut )
      DEALLOCATE( Count )

      DEALLOCATE( PeA )
      DEALLOCATE( GlobalA )
      DEALLOCATE( BlockSizesA )
      DEALLOCATE( DisplacementsA )

      DEALLOCATE( GlobalB )
      DEALLOCATE( BlockSizesB )
      DEALLOCATE( DisplacementsB )

      CPP_LEAVE_PROCEDURE( "PARPATTERNGHOSTTOGHOST" )
      RETURN
!EOC
      END SUBROUTINE ParPatternGhostToGhost
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParPatternFree --- Free the communication pattern
!
! !INTERFACE:
      SUBROUTINE ParPatternFree( InComm, Pattern )
!
! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER,  INTENT( IN )                 :: InComm  ! # of PEs
! !INPUT/OUTPUT PARAMETERS:
      TYPE(ParPatternType), INTENT( INOUT )  :: Pattern ! Comm Pattern
!
! !DESCRIPTION:
!     This routine frees a communication pattern.  
!
! !SYSTEM ROUTINES:
!     MPI_TYPE_FREE
!
! !BUGS:
!     The MPI_TYPE_FREE statement does not seem to work with FFC
!
! !REVISION HISTORY:
!   01.02.10   Sawyer     Creation
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER  ipe, GroupSize, Pointer, Ierror, method

      CPP_ENTER_PROCEDURE( "PARPATTERNFREE" )

      method = Pattern%RecvDesc(1)%method

!
! First request the needed ghost values from other processors.
!
! Free all the MPI derived types
!
      DO ipe=1, Pattern%Size
        Pointer = Pattern%SendDesc(ipe)%type
        IF ( Pointer /= MPI_DATATYPE_NULL ) THEN
          CALL MPI_TYPE_FREE( Pointer, Ierror )
        ENDIF
        Pointer = Pattern%RecvDesc(ipe)%type
        IF ( Pointer /= MPI_DATATYPE_NULL ) THEN
          CALL MPI_TYPE_FREE( Pointer, Ierror )
        ENDIF
      ENDDO

      DO ipe=1, size(Pattern%RecvDesc)
        DEALLOCATE( Pattern%RecvDesc(ipe)%Displacements )
        DEALLOCATE( Pattern%RecvDesc(ipe)%BlockSizes )
      ENDDO
      DO ipe=1, size(Pattern%SendDesc)
        DEALLOCATE( Pattern%SendDesc(ipe)%Displacements )
        DEALLOCATE( Pattern%SendDesc(ipe)%BlockSizes )
      ENDDO

      DEALLOCATE( Pattern%SendDesc )
      DEALLOCATE( Pattern%RecvDesc )

      CPP_LEAVE_PROCEDURE( "PARPATTERNFREE" )
      RETURN
!EOC
      END SUBROUTINE ParPatternFree
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParScatterReal --- Scatter slice to all PEs
!
! !INTERFACE:
      SUBROUTINE ParScatterReal ( InComm, Root, Slice, Decomp, Local )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      REAL(CPP_REAL8), INTENT( IN )  :: Slice(*)     ! Global Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT ) :: Local(*)     ! Local Slice

! !DESCRIPTION:
!     Given a decomposition of the domain, dole out a slice 
!     (one-dimensional array) to all the constituent PEs as described
!     by the decomposition Decomp.
!
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.30   Sawyer     Stats dimension corrected: Gsize*MPI_STATUS_SIZE
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:

      INTEGER Ierror, I, J, K, L, Iam, GroupSize
      INTEGER Status( MPI_STATUS_SIZE )
      Integer, allocatable :: Reqs(:), Stats(:)
      REAL(CPP_REAL8), ALLOCATABLE    :: SendBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARSCATTERREAL" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )

      allocate (Reqs(GroupSize))
      allocate (Stats(GroupSize*MPI_STATUS_SIZE))

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( SendBuf( SUM( Decomp%NumEntries ) ) )
        L = 0
        DO I = 1, GroupSize
!
! Pick out the array sections to be sent.
! This is the inverse of the operation in ParGather
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L+1
              SendBuf(L) = Slice(K)
            ENDDO
          ENDDO
!
! This is a non-blocking send. SendBuf cannot be immediately deallocated
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CALL MPI_ISEND( SendBuf(L-Decomp%NumEntries(I)+1),             &
                          Decomp%NumEntries(I), CPP_MPI_REAL8,           &
                          I-1, 0, InComm, Reqs(I), Ierror )

        ENDDO
      ENDIF

!
! All receive from the root.  
!
! The local array may be larger than that specified in the decomposition
!
      CALL MPI_RECV( Local, Decomp%NumEntries(Iam+1),                    &
                     CPP_MPI_REAL8,                                      &
                     Root, 0, InComm, Status, Ierror )
!
! Experience shows that we should wait for all the non-blocking
! PEs to check in, EVEN THOUGH THE MPI_RECV HAS COMPLETED !!
!
      IF ( Iam .EQ. Root ) THEN
        CALL MPI_WAITALL( GroupSize, Reqs, Stats, Ierror )
        DEALLOCATE( SendBuf )
      ENDIF

!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PARSCATTERREAL" )
      RETURN
!EOC
      END SUBROUTINE ParScatterReal
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParScatterReal4 --- Scatter slice to all PEs
!
! !INTERFACE:
      SUBROUTINE ParScatterReal4 ( InComm, Root, Slice, Decomp, Local )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      REAL(CPP_REAL4), INTENT( IN )  :: Slice(*)     ! Global Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL4), INTENT( OUT ) :: Local(*)     ! Local Slice

! !DESCRIPTION:
!     Given a decomposition of the domain, dole out a slice 
!     (one-dimensional array) to all the constituent PEs as described
!     by the decomposition Decomp.
!
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.30   Sawyer     Stats dimension corrected: Gsize*MPI_STATUS_SIZE
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:

      INTEGER Ierror, I, J, K, L, Iam, GroupSize
      INTEGER Status( MPI_STATUS_SIZE )
      Integer, allocatable :: Reqs(:), Stats(:)
      REAL(CPP_REAL4), ALLOCATABLE    :: SendBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARSCATTERREAL4" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )

      allocate (Reqs(GroupSize))
      allocate (Stats(GroupSize*MPI_STATUS_SIZE))

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( SendBuf( SUM( Decomp%NumEntries ) ) )
        L = 0
        DO I = 1, GroupSize
!
! Pick out the array sections to be sent.
! This is the inverse of the operation in ParGather
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L+1
              SendBuf(L) = Slice(K)
            ENDDO
          ENDDO
!
! This is a non-blocking send. SendBuf cannot be immediately deallocated
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CALL MPI_ISEND( SendBuf(L-Decomp%NumEntries(I)+1),             &
                          Decomp%NumEntries(I), CPP_MPI_REAL4,           &
                          I-1, 0, InComm, Reqs(I), Ierror )

        ENDDO
      ENDIF

!
! All receive from the root.  
!
! The local array may be larger than that specified in the decomposition
!
      CALL MPI_RECV( Local, Decomp%NumEntries(Iam+1),                    &
                     CPP_MPI_REAL4,                                      &
                     Root, 0, InComm, Status, Ierror )
!
! Experience shows that we should wait for all the non-blocking
! PEs to check in, EVEN THOUGH THE MPI_RECV HAS COMPLETED !!
!
      IF ( Iam .EQ. Root ) THEN
        CALL MPI_WAITALL( GroupSize, Reqs, Stats, Ierror )
        DEALLOCATE( SendBuf )
      ENDIF

!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PARSCATTERREAL4" )
      RETURN
!EOC
      END SUBROUTINE ParScatterReal4
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParScatterInt --- Scatter slice to all PEs
!
! !INTERFACE:
      SUBROUTINE ParScatterInt ( InComm, Root, Slice, Decomp, Local )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      INTEGER, INTENT( IN )          :: Slice(*)     ! Global Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )         :: Local(*)     ! Local Slice

! !DESCRIPTION:
!     Given a decomposition of the domain, dole out a slice 
!     (one-dimensional array) to all the constituent PEs as described
!     by the decomposition Decomp.
!
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.30   Sawyer     Stats dimension corrected: Gsize*MPI_STATUS_SIZE
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:

      INTEGER Ierror, I, J, K, L, Iam, GroupSize
      INTEGER Status( MPI_STATUS_SIZE )
      Integer, allocatable :: Reqs(:), Stats(:)
      INTEGER, ALLOCATABLE    :: SendBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARSCATTERINT" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )

      allocate (Reqs(GroupSize))
      allocate (Stats(GroupSize*MPI_STATUS_SIZE))

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( SendBuf( SUM( Decomp%NumEntries ) ) )
        L = 0
        DO I = 1, GroupSize
!
! Pick out the array sections to be sent.
! This is the inverse of the operation in ParGather
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L+1
              SendBuf(L) = Slice(K)
            ENDDO
          ENDDO
!
! This is a non-blocking send. SendBuf cannot be immediately deallocated
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CALL MPI_ISEND( SendBuf(L-Decomp%NumEntries(I)+1),              &
                          Decomp%NumEntries(I), CPP_MPI_INTEGER,          &
                          I-1, 0, InComm, Reqs(I), Ierror )

        ENDDO
      ENDIF

!
! All receive from the root.  
!
! The local array may be larger than that specified in the decomposition
!
      CALL MPI_RECV( Local, Decomp%NumEntries(Iam+1),                     &
                     CPP_MPI_INTEGER,                                     &
                     Root, 0, InComm, Status, Ierror )
!
! Experience shows that we should wait for all the non-blocking
! PEs to check in, EVEN THOUGH THE MPI_RECV HAS COMPLETED !!
!
      IF ( Iam .EQ. Root ) THEN
        CALL MPI_WAITALL( GroupSize, Reqs, Stats, Ierror )
        DEALLOCATE( SendBuf )
      ENDIF

!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PARSCATTERINT" )
      RETURN
!EOC
      END SUBROUTINE ParScatterInt
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParGatherReal --- Gather Slice from all PEs
!
! !INTERFACE:  
      SUBROUTINE ParGatherReal ( InComm, Root, Local, Decomp, Slice )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      REAL(CPP_REAL8), INTENT( IN )  :: Local(*)     ! Local Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT ) :: Slice(*)     ! Global Slice

! !DESCRIPTION:
!     Given a decomposition of the domain and a local portion of the
!     total slice on each PE, gather together the portions into a
!     global slice on the root PE
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.01.29   Sawyer     Corrected assertions
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.31   Sawyer     Stat dimension corrected: MPI_STATUS_SIZE
!   98.04.22   Sawyer     Local no longer assumed shape: Local(*)
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER Ierror, I, J, K, L, Iam, GroupSize, Req
      INTEGER Status( MPI_STATUS_SIZE ), Stat( MPI_STATUS_SIZE )
      REAL(CPP_REAL8), ALLOCATABLE    :: RecvBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARGATHERREAL" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
!
! All PEs send their contribution to the root
!
      CALL MPI_ISEND( Local, Decomp%NumEntries(Iam+1),                   &
                      CPP_MPI_REAL8,                                     &
                      Root, Iam+3001, InComm, Req, Ierror )

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( RecvBuf( SUM( Decomp%NumEntries ) ) )
!
! On the Root PE receive from every other PE
!
        L = 0
        DO I = 1, GroupSize
!
! This is a blocking, synchronous recv.  All the
! sends should have been posted so it should not deadlock
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CPP_ASSERT_F90( L .LT. SIZE( RecvBuf ) )
          CALL MPI_RECV( RecvBuf(L+1), Decomp%NumEntries(I),             &
                         CPP_MPI_REAL8, I-1, I+3000, InComm,             &
                         Status, Ierror )
!
! This is the simple reverse mapping of that in ParScatter
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L + 1
              Slice(K) = RecvBuf(L)
#if defined(DEBUG_PARGATHERREAL)
                PRINT *, " Entry ", L, RecvBuf(L), K, SIZE(Slice)
#endif
            ENDDO
          ENDDO
        ENDDO
        DEALLOCATE( RecvBuf )
      ENDIF
      CALL MPI_WAIT( Req, Stat, Ierror )
!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )

      CPP_LEAVE_PROCEDURE( "PARGATHERREAL" )
      RETURN
!EOC
      END SUBROUTINE ParGatherReal
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParGatherReal4 --- Gather Slice from all PEs
!
! !INTERFACE:  
      SUBROUTINE ParGatherReal4 ( InComm, Root, Local, Decomp, Slice )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      REAL(CPP_REAL4), INTENT( IN )  :: Local(*)     ! Local Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL4), INTENT( OUT ) :: Slice(*)     ! Global Slice

! !DESCRIPTION:
!     Given a decomposition of the domain and a local portion of the
!     total slice on each PE, gather together the portions into a
!     global slice on the root PE
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.01.29   Sawyer     Corrected assertions
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.31   Sawyer     Stat dimension corrected: MPI_STATUS_SIZE
!   98.04.22   Sawyer     Local no longer assumed shape: Local(*)
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER Ierror, I, J, K, L, Iam, GroupSize, Req
      INTEGER Status( MPI_STATUS_SIZE ), Stat( MPI_STATUS_SIZE )
      REAL(CPP_REAL4), ALLOCATABLE    :: RecvBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARGATHERREAL4" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
!
! All PEs send their contribution to the root
!
      CALL MPI_ISEND( Local, Decomp%NumEntries(Iam+1),                   &
                      CPP_MPI_REAL4,                                     &
                      Root, Iam+3001, InComm, Req, Ierror )

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( RecvBuf( SUM( Decomp%NumEntries ) ) )
!
! On the Root PE receive from every other PE
!
        L = 0
        DO I = 1, GroupSize
!
! This is a blocking, synchronous recv.  All the
! sends should have been posted so it should not deadlock
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CPP_ASSERT_F90( L .LT. SIZE( RecvBuf ) )
          CALL MPI_RECV( RecvBuf(L+1), Decomp%NumEntries(I),             &
                         CPP_MPI_REAL4, I-1, I+3000, InComm,             &
                         Status, Ierror )
!
! This is the simple reverse mapping of that in ParScatter
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L + 1
              Slice(K) = RecvBuf(L)
#if defined(DEBUG_PARGATHERREAL4)
                PRINT *, " Entry ", L, RecvBuf(L), K, SIZE(Slice)
#endif
            ENDDO
          ENDDO
        ENDDO
        DEALLOCATE( RecvBuf )
      ENDIF
      CALL MPI_WAIT( Req, Stat, Ierror )
!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )
      CPP_LEAVE_PROCEDURE( "PARGATHERREAL4" )
      RETURN
!EOC
      END SUBROUTINE ParGatherReal4
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParGatherInt --- Gather Slice from all PEs
!
! !INTERFACE:  
      SUBROUTINE ParGatherInt ( InComm, Root, Local, Decomp, Slice )

! !USES:
      USE decompmodule, ONLY:  DecompType, Lists
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )          :: InComm       ! Communicator
      INTEGER, INTENT( IN )          :: Root         ! Root PE
      INTEGER, INTENT( IN )          :: Local(*)     ! Local Slice
      TYPE(DecompType), INTENT( IN ) :: Decomp       ! Decomp information

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )         :: Slice(*)     ! Global Slice

! !DESCRIPTION:
!     Given a decomposition of the domain and a local portion of the
!     total slice on each PE, gather together the portions into a
!     global slice on the root PE
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_COMM_RANK
!
! !REVISION HISTORY:
!   97.04.14   Sawyer     Creation
!   97.04.16   Sawyer     Cleaned up for walk-through
!   97.05.01   Sawyer     Use Decomp%Comm for all local info
!   97.05.18   Sawyer     DecompType has moved to ParUtilitiesTypes
!   97.05.29   Sawyer     Changed 2-D arrays to 1-D
!   97.07.03   Sawyer     Reformulated documentation
!   97.07.22   Sawyer     DecompType has moved to DecompModule
!   97.12.01   Sawyer     Changed MPI_SSEND to MPI_ISEND
!   97.12.05   Sawyer     Added InComm and Root as arguments
!   97.12.05   Sawyer     Added logic to support intercommunicators
!   98.01.24   Sawyer     Removed dependence on MPI derived types TESTED
!   98.01.29   Sawyer     Corrected assertions
!   98.02.05   Sawyer     Removed the use of intercommunicators
!   98.03.31   Sawyer     Stat dimension corrected: MPI_STATUS_SIZE
!   98.04.22   Sawyer     Local no longer assumed shape: Local(*)
!   99.01.19   Sawyer     Dropped assumed-size arrays
!   00.07.07   Sawyer     Removed "1D" references
!   00.07.23   Sawyer     Implementation with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER Ierror, I, J, K, L, Iam, GroupSize, Req
      INTEGER Status( MPI_STATUS_SIZE ), Stat( MPI_STATUS_SIZE )
      INTEGER, ALLOCATABLE    :: RecvBuf(:)
!
      CPP_ENTER_PROCEDURE( "PARGATHERINT" )
!
      CALL MPI_COMM_RANK( InComm, Iam, Ierror )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierror )
!
! All PEs send their contribution to the root
!
      CALL MPI_ISEND( Local, Decomp%NumEntries(Iam+1), CPP_MPI_INTEGER,       &
                      Root, Iam+3001, InComm, Req, Ierror )

      IF ( Iam .EQ. Root ) THEN
        ALLOCATE( RecvBuf( SUM( Decomp%NumEntries ) ) )
!
! On the Root PE receive from every other PE
!
        L = 0
        DO I = 1, GroupSize
!
! This is a blocking, synchronous recv.  All the
! sends should have been posted so it should not deadlock
!
! WARNING: F90-MPI inconsistency: make sure the indexing below always works
!
          CPP_ASSERT_F90( L .LT. SIZE( RecvBuf ) )
          CALL MPI_RECV( RecvBuf(L+1), Decomp%NumEntries(I),                  &
                         CPP_MPI_INTEGER, I-1, I+3000, InComm,                &
                         Status, Ierror )
!
! This is the simple reverse mapping of that in ParScatter
!
          DO J = 1, SIZE( Decomp%HEAD(I)%StartTags )
            DO K = Decomp%HEAD(I)%StartTags(J),Decomp%HEAD(I)%EndTags(J)
              L = L + 1
              Slice(K) = RecvBuf(L)
#if defined(DEBUG_PARGATHERINT)
                PRINT *, " Entry ", L, RecvBuf(L), K, SIZE(Slice)
#endif
            ENDDO
          ENDDO
        ENDDO
        DEALLOCATE( RecvBuf )
      ENDIF
      CALL MPI_WAIT( Req, Stat, Ierror )
!
! The following may be needed on some platforms to avoid an MPI bug.
!
      CALL MPI_BARRIER( InComm, Ierror )

      CPP_LEAVE_PROCEDURE( "PARGATHERINT" )
      RETURN
!EOC
      END SUBROUTINE ParGatherInt
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferReal --- Start an ASYNC Real Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferReal(InComm, NrInPackets, NrOutPackets, &
                                      Dest, Src, InBuf, InIA,            &
                                      OutBuf, OutIA )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      INTEGER, INTENT( IN )       :: NrInPackets  ! Number of in packets
      INTEGER, INTENT( IN )       :: NrOutPackets ! Number of out packets
      INTEGER, INTENT( IN )       :: Dest(:)      ! PE destinations
      INTEGER, INTENT( IN )       :: Src(:)       ! PE sources
      REAL(CPP_REAL8), INTENT(IN) :: InBuf(:)     ! Input buffer
      INTEGER, INTENT( IN )       :: InIA(:)      ! In packet counter
      INTEGER, INTENT( IN )       :: OutIA(:)     ! Out packet counter

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT ) :: OutBuf(:)  ! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf
!     partitioned into parcels defined by the arrays InIA and Dest
!     to an output array OutBuf on another PE. InIA(1) contains 
!     the number of reals to be sent to Dest(1), InIA(2) the number 
!     of reals to be sent to Dest(2), etc.  Similarly, the array
!     OutBuf on the calling PE is partitioned into parcels by OutIA
!     and Src, with OutIA(1) the number of reals anticipated from
!     Src(1), etc.  
!
!     The default implementation reads through the contiguous array 
!     InBuf and sends the parcels to the PEs designated with an 
!     asyncronous MPI\_ISEND.  Correspondingly it posts the receives 
!     with an asynchronous MPI\_IRECV.
!
!     Wait handles InHandle(:) and OutHandle(:) are in common block.
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference!!!!!!!!!!
!
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.
!
!
! !SYSTEM ROUTINES:
!     MPI_COMM_RANK, MPI_ISEND, MPI_IRECV
!
! !REVISION HISTORY:
!   97.09.26   Sawyer     Creation
!   97.12.05   Sawyer     Renamed Comm to InComm to avoid collisions
!   98.02.26   Sawyer     Added Dest, Src and Remote to clean up code
!   98.04.16   Sawyer     Number of packets become input arguments
!   98.09.04   Sawyer     Cleaned interface: handles in common, no Remote
!   99.03.04   Sawyer     Inlined ParCalculateRemote
!   99.06.01   Sawyer     Changed pointer arrays to INTEGER*8 for SGI
!   00.08.07   Sawyer     Implementation with shared memory arenas
!   01.09.27   Sawyer     Added multiple shared buffers for USE_MLP
!
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      INTEGER Iam, GroupSize, Nr, Icnt, Packet, I, Ierr

      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERREAL" )
      CPP_ASSERT_F90( NrInPackets .LE. SIZE( Dest ) )
      CPP_ASSERT_F90( NrInPackets .LE. SIZE( InIA ) )
      CPP_ASSERT_F90( NrOutPackets .LE. SIZE( Src ) )
      CPP_ASSERT_F90( NrOutPackets .LE. SIZE( OutIA ) )

!
! Increment the ongoing transfer number
      BegTrf = MOD(BegTrf,MAX_TRF) + 1

      CALL MPI_COMM_RANK( InComm, Iam, Ierr )
      CALL MPI_COMM_SIZE( InComm, GroupSize, Ierr )

!
!     MPI: Irecv over all processes
!
      Icnt = 1
      DO Packet = 1, NrOutPackets
        Nr = OutIA( Packet )
        IF ( Nr .GT. 0 ) THEN
#if defined( DEBUG_PARBEGINTRANSFERREAL )
          PRINT *, "Iam ",Iam," posts recv ",Nr," from ", Src( Packet )
#endif
!
! Receive the buffers with MPI_Irecv. Non-blocking
!
          CPP_ASSERT_F90( Icnt+Nr-1 .LE. SIZE( OutBuf ) )
          CALL MPI_IRECV( OutBuf( Icnt ), Nr,                            &
                CPP_MPI_REAL8, Src( Packet ), Src( Packet ),             &
                InComm, OutHandle(Packet,1,BegTrf), Ierr )
        ELSE
          OutHandle(Packet,1,BegTrf) = MPI_REQUEST_NULL
        END IF
        Icnt = Icnt + Nr
      END DO
!
!     MPI: Isend over all processes
!
      Icnt = 1
      CPP_ASSERT_F90( NrInPackets .LE. SIZE( Dest ) )
      CPP_ASSERT_F90( NrInPackets .LE. SIZE( InIA ) )
      DO Packet = 1, NrInPackets
        Nr = InIA( Packet )
        IF ( Nr .GT. 0 ) THEN
#if defined( DEBUG_PARBEGINTRANSFERREAL )
          PRINT *,"Iam ",Iam," posts send ",Nr," to ",Dest( Packet )
#endif
!
!     Send the individual buffers with non-blocking sends
!
          CPP_ASSERT_F90( Icnt+Nr-1 .LE. SIZE( InBuf ) )
          CALL MPI_ISEND ( InBuf( Icnt ), Nr,                            &
                CPP_MPI_REAL8, Dest( Packet ), Iam,                      &
                InComm, InHandle(Packet,1,BegTrf), Ierr )
        ELSE
          InHandle(Packet,1,BegTrf) = MPI_REQUEST_NULL
        END IF
        Icnt = Icnt + Nr
      END DO
!
!
      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERREAL" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferReal
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferPattern1D --- Start ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferPattern1D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_sendirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern   ! Comm Pattern
      REAL(CPP_REAL8), INTENT( IN )        :: InBuf(*)  ! Input buffer

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( OUT )       :: OutBuf(*) ! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf.
!     The communication pattern indicates the indices outgoing 
!     values of InBuf and  incoming values for OutBuf.  This routine
!     is fundamentally equivalent to ParBeginTransferReal; the use 
!     of a communication pattern is largely a performance enhancement, 
!     since it eliminates the need for intermediate buffering.
!     
!     Wait handles InHandle and OutHandle are module variables
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.02.14   Sawyer     Creation from ParBeginTransferReal
!   01.09.27   Sawyer     Added multiple shared buffers for USE_MLP
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_sendirr
!
!EOP
!-----------------------------------------------------------------------
!BOC

! !LOCAL VARIABLES:
      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERPATTERN1D" )

      CALL mp_sendirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )
!
      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERPATTERN1D" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferPattern1D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferPattern1Dint --- Start ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferPattern1Dint( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_sendirr_i4
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern   ! Comm Pattern
      INTEGER, INTENT( IN )                :: InBuf(*)  ! Input buffer

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )               :: OutBuf(*) ! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf.
!     The communication pattern indicates the indices outgoing 
!     values of InBuf and  incoming values for OutBuf.  This routine
!     is fundamentally equivalent to ParBeginTransferReal; the use 
!     of a communication pattern is largely a performance enhancement, 
!     since it eliminates the need for intermediate buffering.
!     
!     Wait handles InHandle and OutHandle are module variables
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.02.14   Sawyer     Creation from ParBeginTransferReal
!   01.09.27   Sawyer     Added multiple shared buffers for USE_MLP
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_sendirr_i4
! 
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERPATTERN1DINT" )

      CALL mp_sendirr_i4( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERPATTERN1DINT" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferPattern1Dint
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferPattern2D --- Start an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferPattern2D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_sendirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT(IN)  :: Pattern      ! Comm Pattern
      REAL(CPP_REAL8), INTENT(IN)        :: InBuf(:,:)   ! Input buffer

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT(OUT)       :: OutBuf(:,:)  ! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf.
!     The communication pattern indicates the indices outgoing 
!     values of InBuf and  incoming values for OutBuf.  This routine
!     is fundamentally equivalent to ParBeginTransferReal; the use 
!     of a communication pattern is largely a performance enhancement, 
!     since it eliminates the need for intermediate buffering.
!
!     Wait handles InHandle and OutHandle are module variables
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.  
!
! !REVISION HISTORY:
!   01.10.01   Sawyer     Creation from ParBeginTransferPattern
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_sendirr
! 
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERPATTERN2D" )

      CALL mp_sendirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERPATTERN2D" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferPattern2D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferPattern3D --- Start an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferPattern3D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_sendirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT(IN)  :: Pattern      ! Comm Pattern
      REAL(CPP_REAL8), INTENT(IN)        :: InBuf(:,:,:) ! Input buffer

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT(OUT)       :: OutBuf(:,:,:)! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf.
!     The communication pattern indicates the indices outgoing 
!     values of InBuf and  incoming values for OutBuf.  This routine
!     is fundamentally equivalent to ParBeginTransferReal; the use 
!     of a communication pattern is largely a performance enhancement, 
!     since it eliminates the need for intermediate buffering.
!
!     Wait handles InHandle and OutHandle are module variables
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.  
!
! !REVISION HISTORY:
!   01.10.01   Sawyer     Creation from ParBeginTransferPattern
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_sendirr
! 
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERPATTERN3D" )

      CALL mp_sendirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERPATTERN3D" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferPattern3D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParBeginTransferPattern4D --- Start an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParBeginTransferPattern4D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_sendirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT(IN)  :: Pattern        ! Comm Pattern
      REAL(CPP_REAL8), INTENT(IN)        :: InBuf(:,:,:,:) ! Input buffer

! !OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT(OUT)       :: OutBuf(:,:,:,:)! Output buffer

! !DESCRIPTION: 
!
!     This routine initiates an async. transfer of an array InBuf.
!     The communication pattern indicates the indices outgoing 
!     values of InBuf and  incoming values for OutBuf.  This routine
!     is fundamentally equivalent to ParBeginTransferReal; the use 
!     of a communication pattern is largely a performance enhancement, 
!     since it eliminates the need for intermediate buffering.
!
!     Wait handles InHandle and OutHandle are module variables
!     The buffers may not be accessed until after the call to 
!     ParEndTransferReal.  
!
! !REVISION HISTORY:
!   02.12.19   Sawyer     Creation from ParBeginTransferPattern
!   03.06.24   Sawyer     All complexity now in mp_sendirr
! 
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARBEGINTRANSFERPATTERN4D" )

      CALL mp_sendirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARBEGINTRANSFERPATTERN4D" )
      RETURN
!EOC
      END SUBROUTINE ParBeginTransferPattern4D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferReal --- Complete an ASYNC Real Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferReal( InComm, NrInPackets, NrOutPackets,  &
                                     Dest, Src, InBuf, InIA,             &
                                     OutBuf, OutIA )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      INTEGER, INTENT( IN )       :: NrInPackets  ! Number of in packets
      INTEGER, INTENT( IN )       :: NrOutPackets ! Number of out packets
      INTEGER, INTENT( IN )       :: Dest(:)      ! PE destinations
      INTEGER, INTENT( IN )       :: Src(:)       ! PE sources
      REAL(CPP_REAL8), INTENT(IN) :: InBuf(:)     ! Input buffer
      INTEGER, INTENT( IN )       :: InIA(:)      ! Pointer array
      INTEGER, INTENT( IN )       :: OutIA(:)     ! Pointer array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT ) :: OutBuf(:)! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array
!     partitioned into parcels defined by the array InIA.  In the 
!     MPI version, neither InBuf nor OutBuf is not used since
!     that information was utilized in ParBeginTransferReal.
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference! The buffers may not be accessed until after the 
!     completion of ParEndTransferReal.  
!
!
! !SYSTEM ROUTINES:
!     MPI_COMM_RANK, MPI_ISEND, MPI_IRECV
!
! !REVISION HISTORY:
!   97.09.26   Sawyer     Creation
!   97.12.05   Sawyer     Renamed Comm to InComm to avoid collisions
!   98.02.26   Sawyer     Count through packets, not PEs
!   98.04.16   Sawyer     Number of packets become input arguments
!   98.09.04   Sawyer     Cleaned interface: handles in common
!   99.03.05   Sawyer     Support for contiguous communicators in SHMEM
!   99.04.22   Sawyer     Bug fix: replaced MPI_WAIT with MPI_WAITALL
!   99.06.03   Sawyer     Bug fix: GroupSize in SHMEM_BARRIER
!   00.07.28   Sawyer     Implemented with shared memory arenas
!   01.09.27   Sawyer     Added multiple shared buffers for USE_MLP
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      INTEGER Iam, GroupSize, J, Offset, Packet, Ierr
      INTEGER InStats(NrInPackets*MPI_STATUS_SIZE)
      INTEGER OutStats(NrOutPackets*MPI_STATUS_SIZE)

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERREAL" )

!
! Increment the receiver 
      EndTrf = MOD(EndTrf,MAX_TRF)+1

      CPP_ASSERT_F90( NrInPackets .LE. MAX_PAX )
      CALL MPI_WAITALL( NrInPackets, InHandle(:,1,EndTrf), InStats, Ierr )
 
      CPP_ASSERT_F90( NrOutPackets .LE. MAX_PAX )
      CALL MPI_WAITALL( NrOutPackets, OutHandle(:,1,EndTrf), OutStats, Ierr )
!
! WS 98.09.22 : This barrier needed to synchronize.
!
      CALL MPI_BARRIER( InComm, Ierr )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERREAL" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferReal
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferPattern1D --- Complete ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferPattern1D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_recvirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern   ! Comm Pattern
      REAL(CPP_REAL8), INTENT( IN )        :: InBuf(*)  ! Input buffer

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT )     :: OutBuf(*) ! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array communicated
!     with a communication pattern.  
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!     The buffers may not be accessed until after the 
!     completion of ParEndTransfer.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.02.14   Sawyer     Creation from ParEndTransferReal
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_recvirr
!
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERPATTERN1D" )

      CALL mp_recvirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERPATTERN1D" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferPattern1D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferPattern1Dint --- Complete ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferPattern1Dint( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_recvirr_i4
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern   ! Comm Pattern
      INTEGER, INTENT( IN )                :: InBuf(*)  ! Input buffer

! !INPUT/OUTPUT PARAMETERS:
      INTEGER, INTENT( INOUT )             :: OutBuf(*) ! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array communicated
!     with a communication pattern.  
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!     The buffers may not be accessed until after the 
!     completion of ParEndTransfer.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.02.14   Sawyer     Creation from ParEndTransferReal
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_recvirr_i4
!
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERPATTERN1DINT" )

      CALL mp_recvirr_i4( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERPATTERN1DINT" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferPattern1Dint
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferPattern2D --- Complete an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferPattern2D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_recvirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern       ! Comm Pattern
      REAL(CPP_REAL8), INTENT( IN )        :: InBuf(:,:)    ! Input buffer

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT )     :: OutBuf(:,:)   ! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array communicated
!     with a communication pattern.  
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!     The buffers may not be accessed until after the 
!     completion of ParEndTransfer.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.10.01   Sawyer     Creation from ParEndTransferPattern
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_recvirr
!
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERPATTERN2D" )

      CALL mp_recvirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf(:,:),OutBuf(:,:) )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERPATTERN2D" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferPattern2D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferPattern3D --- Complete an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferPattern3D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_recvirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern       ! Comm Pattern
      REAL(CPP_REAL8), INTENT( IN )        :: InBuf(:,:,:)  ! Input buffer

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT )     :: OutBuf(:,:,:) ! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array communicated
!     with a communication pattern.  
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!     The buffers may not be accessed until after the 
!     completion of ParEndTransfer.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   01.10.01   Sawyer     Creation from ParEndTransferPattern
!   02.08.13   Sawyer     Now uses mod_comm unless Use_Mpi_Types
!   03.06.24   Sawyer     All complexity now in mp_recvirr
!
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERPATTERN3D" )

      CALL mp_recvirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf(:,:,:),OutBuf(:,:,:) )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERPATTERN3D" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferPattern3D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParEndTransferPattern4D --- Complete an ASYNC Pattern Transfer
!
! !INTERFACE:
      SUBROUTINE ParEndTransferPattern4D( InComm, Pattern, InBuf, OutBuf )

! !USES:
      USE mod_comm, ONLY : mp_recvirr
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )       :: InComm       ! Communicator
      TYPE (ParPatternType), INTENT( IN )  :: Pattern        ! Comm Pattern
      REAL(CPP_REAL8), INTENT( IN )        :: InBuf(:,:,:,:) ! Input buffer

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT )     :: OutBuf(:,:,:,:)! Output buffer

! !DESCRIPTION: 
!
!     This routine completes an async. transfer of an array communicated
!     with a communication pattern.  
!
!     The link between StartTransfer and EndTransfer is made possible
!     by the InHandle and OutHandle: they reflect the status of
!     the ongoing transfer.  When this routine completes, a valid
!     and accessible copy of the OutBuf is ready for use.
!     The buffers may not be accessed until after the 
!     completion of ParEndTransfer.  
!
! !BUGS:
!
!     It is assumed that the buffers are passed to this routine by
!     reference.
!
! !REVISION HISTORY:
!   02.12.19   Sawyer     Creation from ParEndTransferPattern
!   03.06.24   Sawyer     All complexity now in mp_recvirr
!
!EOP
!-----------------------------------------------------------------------
!BOC

      CPP_ENTER_PROCEDURE( "PARENDTRANSFERPATTERN4D" )

      CALL mp_recvirr( InComm,Pattern%SendDesc,Pattern%RecvDesc,InBuf,OutBuf )

      CPP_LEAVE_PROCEDURE( "PARENDTRANSFERPATTERN4D" )
      RETURN
!EOC
      END SUBROUTINE ParEndTransferPattern4D
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParExchangeVectorReal --- Exchange a sparse packed vector
!
! !INTERFACE:  
      SUBROUTINE ParExchangeVectorReal ( InComm, LenInVector, InVector,  &
                                         LenOutVector, OutVector )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )   :: InComm            ! Communicator
      INTEGER, INTENT( IN )   :: LenInVector( * )  ! Length on each PE
      REAL(CPP_REAL8), INTENT( IN ):: InVector( * ) ! The input buffer

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )  :: LenOutVector( * ) ! Length on each PE
      REAL(CPP_REAL8), INTENT( OUT ) :: OutVector( * ) ! The output buffer

! !DESCRIPTION:
!
!     This routine exchanges vectors stored in compressed format, i.e.,
!     in so-called compressed sparse row (CSR) format, with other
!     PEs.  In essence it first exchanges the lengths with
!     MPI\_Alltoall, then the exchange of the actual vectors (can be
!     different in size) using MPI\_AlltoallV.  Since the latter is
!     inefficient, it is simulated using MPI\_Isend and MPI\_Recv.
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_WAITALL, MPI_ALLTOALL
!
! !REVISION HISTORY:
!   98.03.17   Sawyer     Creation from F77 version
!   98.03.30   Sawyer     Removed assumed shape arrays due to problems
!   99.01.18   Sawyer     Added barrier for safety
!   99.03.08   Sawyer     USE_SHMEM version for CRAY only; untested
!   99.06.01   Sawyer     USE_SHMEM version revised per comments from Tom
!   00.07.28   Sawyer     Implemented with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      INTEGER :: i, iscnt, ircnt, nr, pe, icnt, Nsize, Iam, Ierr
      INTEGER :: Status(MPI_STATUS_SIZE)
      Integer, allocatable :: Reqs(:), Stats(:)

      CPP_ENTER_PROCEDURE( "PAREXCHANGEVECTORREAL" )

      CALL MPI_COMM_SIZE( InComm, Nsize, Ierr )
      CALL MPI_COMM_RANK( InComm, Iam, Ierr )

      allocate (Reqs(Nsize))
      allocate (Stats(Nsize*MPI_STATUS_SIZE))

#if defined( MY_ALLTOALL )
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        CALL MPI_ISEND( nr, 1, CPP_MPI_INTEGER, pe, Iam+3000,             &
                        InComm, Reqs( pe+1 ), Ierr )
      ENDDO
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking.
!
        CALL MPI_RECV( nr, 1, CPP_MPI_INTEGER, pe, pe+3000,               &
                       InComm, Status, Ierr )
        LenOutVector(pe + 1) = nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )
#else
      CALL MPI_ALLTOALL( LenInVector, 1, CPP_MPI_INTEGER,                 &
                         LenOutVector, 1, CPP_MPI_INTEGER,                &
                         InComm, Ierr )
#endif
!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        IF ( nr .gt. 0 ) THEN
          CALL MPI_ISEND( InVector( icnt ), nr,                           &
                          CPP_MPI_REAL8, pe, Iam+2000,                    &
                          InComm, Reqs( pe+1 ), Ierr )
        ELSE
          Reqs( pe+1 ) = MPI_REQUEST_NULL
        ENDIF
        icnt = icnt + nr
      ENDDO

!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking. 
!
        nr = LenOutVector(pe + 1)
        IF ( nr .gt. 0 ) THEN
          CALL MPI_RECV( OutVector( icnt ), nr,                          &
                         CPP_MPI_REAL8, pe, pe+2000,                     &
                         InComm, Status, Ierr )
        ENDIF
        icnt = icnt + nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PAREXCHANGEVECTORREAL" )

      RETURN
!EOC
      END SUBROUTINE ParExchangeVectorReal
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParExchangeVectorReal4 --- Exchange a sparse packed vector
!
! !INTERFACE:  
      SUBROUTINE ParExchangeVectorReal4 ( InComm, LenInVector, InVector,&
                                          LenOutVector, OutVector )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )   :: InComm            ! Communicator
      INTEGER, INTENT( IN )   :: LenInVector( * )  ! Length on each PE
      REAL(CPP_REAL4), INTENT( IN ):: InVector( * ) ! The input buffer

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )  :: LenOutVector( * ) ! Length on each PE
      REAL(CPP_REAL4), INTENT( OUT ) :: OutVector( * ) ! The output buffer

! !DESCRIPTION:
!
!     This routine exchanges vectors stored in compressed format, i.e.,
!     in so-called compressed sparse row (CSR) format, with other
!     PEs.  In essence it first exchanges the lengths with
!     MPI\_Alltoall, then the exchange of the actual vectors (can be
!     different in size) using MPI\_AlltoallV.  Since the latter is
!     inefficient, it is simulated using MPI\_Isend and MPI\_Recv.
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_WAITALL, MPI_ALLTOALL
!
! !REVISION HISTORY:
!   98.03.17   Sawyer     Creation from F77 version
!   98.03.30   Sawyer     Removed assumed shape arrays due to problems
!   99.01.18   Sawyer     Added barrier for safety
!   99.03.08   Sawyer     USE_SHMEM version for CRAY only; untested
!   99.06.01   Sawyer     USE_SHMEM version revised per comments from Tom
!   00.07.28   Sawyer     Implemented with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      INTEGER :: i, iscnt, ircnt, nr, pe, icnt, Nsize, Iam, Ierr
      INTEGER :: Status(MPI_STATUS_SIZE)
      Integer, allocatable :: Reqs(:), Stats(:)

      CPP_ENTER_PROCEDURE( "PAREXCHANGEVECTORREAL4" )

      CALL MPI_COMM_SIZE( InComm, Nsize, Ierr )
      CALL MPI_COMM_RANK( InComm, Iam, Ierr )

      allocate (Reqs(Nsize))
      allocate (Stats(Nsize*MPI_STATUS_SIZE))

#if defined( MY_ALLTOALL )
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        CALL MPI_ISEND( nr, 1, CPP_MPI_INTEGER, pe, Iam+3000,             &
                        InComm, Reqs( pe+1 ), Ierr )
      ENDDO
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking.
!
        CALL MPI_RECV( nr, 1, CPP_MPI_INTEGER, pe, pe+3000,               &
                       InComm, Status, Ierr )
        LenOutVector(pe + 1) = nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )
#else
      CALL MPI_ALLTOALL( LenInVector, 1, CPP_MPI_INTEGER,                 &
                         LenOutVector, 1, CPP_MPI_INTEGER,                &
                         InComm, Ierr )
#endif
!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        IF ( nr .gt. 0 ) THEN
          CALL MPI_ISEND( InVector( icnt ), nr,                           &
                          CPP_MPI_REAL4, pe, Iam+2000,                    &
                          InComm, Reqs( pe+1 ), Ierr )
        ELSE
          Reqs( pe+1 ) = MPI_REQUEST_NULL
        ENDIF
        icnt = icnt + nr
      ENDDO

!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking. 
!
        nr = LenOutVector(pe + 1)
        IF ( nr .gt. 0 ) THEN
          CALL MPI_RECV( OutVector( icnt ), nr,                          &
                         CPP_MPI_REAL4, pe, pe+2000,                     &
                         InComm, Status, Ierr )
        ENDIF
        icnt = icnt + nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PAREXCHANGEVECTORREAL4" )

      RETURN
!EOC
      END SUBROUTINE ParExchangeVectorReal4
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParExchangeVectorInt --- Exchange a sparse packed vector
!
! !INTERFACE:  
      SUBROUTINE ParExchangeVectorInt ( InComm, LenInVector, InVector,   &
                                         LenOutVector, OutVector )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )   :: InComm            ! Communicator
      INTEGER, INTENT( IN )   :: LenInVector( * )  ! Length on each PE
      INTEGER, INTENT( IN )   :: InVector( * )     ! The input buffer

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )  :: LenOutVector( * ) ! Length on each PE
      INTEGER, INTENT( OUT )  :: OutVector( * )    ! The output buffer

! !DESCRIPTION:
!
!     This routine exchanges vectors stored in compressed format, i.e.,
!     in so-called compressed sparse row (CSR) format, with other
!     PEs.  In essence it first exchanges the lengths with
!     MPI\_Alltoall, then the exchange of the actual vectors (can be
!     different in size) using MPI\_AlltoallV.  Since the latter is
!     inefficient, it is simulated using MPI\_Isend and MPI\_Recv.
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_WAITALL, MPI_ALLTOALL
!
! !REVISION HISTORY:
!   98.03.17   Sawyer     Creation from F77 version
!   98.03.30   Sawyer     Removed assumed shape arrays due to problems
!   99.01.18   Sawyer     Added barrier for safety
!   99.03.08   Sawyer     USE_SHMEM version for CRAY only; untested
!   99.06.01   Sawyer     USE_SHMEM version revised per comments from Tom
!   00.07.28   Sawyer     Implemented with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      INTEGER :: i, iscnt, ircnt, nr, pe, icnt, Nsize, Iam, Ierr
      INTEGER :: Status(MPI_STATUS_SIZE)
      Integer, allocatable :: Reqs(:), Stats(:)

      CPP_ENTER_PROCEDURE( "PAREXCHANGEVECTORINT" )

      CALL MPI_COMM_SIZE( InComm, Nsize, Ierr )
      CALL MPI_COMM_RANK( InComm, Iam, Ierr )

      allocate (Reqs(Nsize))
      allocate (Stats(Nsize*MPI_STATUS_SIZE))

#if defined( MY_ALLTOALL )
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        CALL MPI_ISEND( nr, 1,                                           &
                        MPI_INTEGER, pe, Iam+3000,                       &
                        InComm, Reqs( pe+1 ), Ierr )
      ENDDO
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking.
!
        CALL MPI_RECV( nr, 1,                                                 &
                       MPI_INTEGER, pe, pe+3000,                              &
                       InComm, Status, Ierr )
        LenOutVector(pe + 1) = nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )
#else
      CALL MPI_ALLTOALL( LenInVector, 1, CPP_MPI_INTEGER,                     &
                         LenOutVector, 1, CPP_MPI_INTEGER,                    &
                         InComm, Ierr )
#endif
!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        IF ( nr .gt. 0 ) THEN
          CALL MPI_ISEND( InVector( icnt ), nr,                               &
                          CPP_MPI_INTEGER, pe, Iam+2000,                      &
                          InComm, Reqs( pe+1 ), Ierr )
        ELSE
          Reqs( pe+1 ) = MPI_REQUEST_NULL
        ENDIF
        icnt = icnt + nr
      ENDDO

!
! Over all processes
!
      icnt = 1
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking. 
!
        nr = LenOutVector(pe + 1)
        IF ( nr .gt. 0 ) THEN
          CALL MPI_RECV( OutVector( icnt ), nr,                               &
                         CPP_MPI_INTEGER, pe, pe+2000,                        &
                         InComm, Status, Ierr )
        ENDIF
        icnt = icnt + nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )
!
! WS 98.09.22 : This barrier needed to synchronize.  Why?
!
      CALL MPI_BARRIER( InComm, Ierr )

      deallocate (Reqs)
      deallocate (Stats)

      CPP_LEAVE_PROCEDURE( "PAREXCHANGEVECTORINT" )

      RETURN
!EOC
      END SUBROUTINE ParExchangeVectorInt
!-----------------------------------------------------------------------


!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollectiveBarrier --- Barrier: Simplest collective op.
!
! !INTERFACE:
      SUBROUTINE ParCollectiveBarrier( InComm )

! !USES:
      IMPLICIT NONE
! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator

! !DESCRIPTION:
!
!     This routine performs a barrier only within the communicator InComm
!     
! !REVISION HISTORY:
!   00.09.10   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror

      CALL MPI_Barrier(InComm, Ierror )

      RETURN
!EOC
      END SUBROUTINE ParCollectiveBarrier
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective0D --- Perform global Collective of a scalar
!
! !INTERFACE:
      SUBROUTINE ParCollective0D( InComm, Op, Var )

! !USES:
      IMPLICIT NONE
! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT ) :: Var  ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL8)    Tmp

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, 1, CPP_MPI_REAL8, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, 1, CPP_MPI_REAL8,                  &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective0D
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective1D --- Perform component-wise global Collective of a vector
!
! !INTERFACE:
      SUBROUTINE ParCollective1D( InComm, Op, Im, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im       ! Size of 1-D array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT ) :: Var(Im) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL8)    Tmp(Im)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im, CPP_MPI_REAL8, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im, CPP_MPI_REAL8,                 &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective1D
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective1DReal4 --- Perform component-wise global Collective of a vector
!
! !INTERFACE:
      SUBROUTINE ParCollective1DReal4( InComm, Op, Im, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im       ! Size of 1-D array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL4), INTENT( INOUT ) :: Var(Im) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL4)    Tmp(Im)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im, CPP_MPI_REAL4, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im, CPP_MPI_REAL4,                 &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective1DReal4
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective2D --- Perform component-wise collective operation
!
! !INTERFACE:
      SUBROUTINE ParCollective2D( InComm, Op, Im, Jm, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm     ! Communicator
      INTEGER, INTENT( IN ) :: Op         ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im         ! First dimension of 2-D array
      INTEGER, INTENT( IN ) :: Jm         ! Second dimension of 2-D array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT ) :: Var(Im,Jm) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL8)    Tmp(Im,Jm)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im*Jm, CPP_MPI_REAL8, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im*Jm, CPP_MPI_REAL8,              &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective2D
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective2DReal4 --- Perform component-wise collective operation
!
! !INTERFACE:
      SUBROUTINE ParCollective2DReal4( InComm, Op, Im, Jm, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm     ! Communicator
      INTEGER, INTENT( IN ) :: Op         ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im         ! First dimension of 2-D array
      INTEGER, INTENT( IN ) :: Jm         ! Second dimension of 2-D array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL4), INTENT( INOUT ) :: Var(Im,Jm) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL4)    Tmp(Im,Jm)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im*Jm, CPP_MPI_REAL4, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im*Jm, CPP_MPI_REAL4,              &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective2DReal4
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective3D --- Perform component-wise global Collective of a vector
!
! !INTERFACE:
      SUBROUTINE ParCollective3D( InComm, Op, Im, Jm, Lm, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm     ! Communicator
      INTEGER, INTENT( IN ) :: Op         ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im         ! First dimension of 3-D array
      INTEGER, INTENT( IN ) :: Jm         ! Second dimension of 3-D array
      INTEGER, INTENT( IN ) :: Lm         ! Third dimension of 3-D array

! !INPUT/OUTPUT PARAMETERS:
      REAL(CPP_REAL8), INTENT( INOUT ):: Var(Im,Jm,LM) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      REAL(CPP_REAL8) Tmp(Im,Jm,Lm)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im*Jm*Lm, CPP_MPI_REAL8, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im*Jm*Lm, CPP_MPI_REAL8,           &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective3D
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective0DInt --- Perform global Collective of a scalar
!
! !INTERFACE:
      SUBROUTINE ParCollective0DInt( InComm, Op, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)

! !INPUT/OUTPUT PARAMETERS:
      INTEGER, INTENT( INOUT ) :: Var   ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      INTEGER    Tmp

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, 1, CPP_MPI_INTEGER, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var,Tmp,1,CPP_MPI_INTEGER,Op,InComm,Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective0DInt
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective0DStr --- Perform global Collective of a string
!
! !INTERFACE:
      SUBROUTINE ParCollective0DStr( InComm, Op, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)

! !INPUT/OUTPUT PARAMETERS:
      CHARACTER (LEN=*), INTENT( INOUT ) :: Var ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in
!     communicator InComm.
!
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror, StrLen

      StrLen = LEN(Var)
      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, StrLen, MPI_CHARACTER, 0, InComm, Ierror )
      ELSE
        write(iulog,*) "global reduction of string not supported"
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective0DStr
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective1DStr --- Perform global Collective of a string
!
! !INTERFACE:
      SUBROUTINE ParCollective1DStr( InComm, Op, Im, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im       ! Size of 1-D array

! !INPUT/OUTPUT PARAMETERS:
      CHARACTER (LEN=*), INTENT( INOUT ) :: Var(:)   ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror, StrLen

      StrLen = LEN(Var(1))
      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im*StrLen, MPI_CHARACTER, 0, InComm, Ierror )
      ELSE
        write(iulog,*) "global reduction of string not supported"
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective1DStr
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective1DInt --- Perform component-wise global 
!                                  collective operations of int vector
!
! !INTERFACE:
      SUBROUTINE ParCollective1DInt( InComm, Op, Im, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm   ! Communicator
      INTEGER, INTENT( IN ) :: Op       ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im       ! Size of 1-D array

! !INPUT/OUTPUT PARAMETERS:
      INTEGER, INTENT( INOUT ) :: Var(Im) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      INTEGER Tmp(Im)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im, CPP_MPI_INTEGER, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var,Tmp,Im,CPP_MPI_INTEGER,Op,InComm,Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective1DInt
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !ROUTINE: ParCollective2DInt --- Perform component-wise collective op.
!
! !INTERFACE:
      SUBROUTINE ParCollective2DInt( InComm, Op, Im, Jm, Var )

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN ) :: InComm     ! Communicator
      INTEGER, INTENT( IN ) :: Op         ! Operation (see header)
      INTEGER, INTENT( IN ) :: Im         ! First dimension of 2-D array
      INTEGER, INTENT( IN ) :: Jm         ! Second dimension of 2-D array

! !INPUT/OUTPUT PARAMETERS:
      INTEGER, INTENT( INOUT ):: Var(Im,Jm) ! partial Var in, Var out

! !DESCRIPTION:
!
!     This utility makes a collective operation over all processes in 
!     communicator InComm.  
!     
! !REVISION HISTORY:
!   00.08.07   Sawyer     Creation
!
!EOP
!---------------------------------------------------------------------
!BOC
      INTEGER Ierror
      INTEGER Tmp(Im,Jm)

      IF ( Op .EQ. BCSTOP ) THEN
        CALL MPI_BCAST( Var, Im*Jm, CPP_MPI_INTEGER, 0, InComm, Ierror )
      ELSE
        CALL MPI_ALLREDUCE( Var, Tmp, Im*Jm, CPP_MPI_INTEGER,           &
                            Op, InComm, Ierror )
        Var = Tmp
      ENDIF

      RETURN
!EOC
      END SUBROUTINE ParCollective2DInt
!-----------------------------------------------------------------------
# ifdef _SMEMORY
!-----------------------------------------------------------------------
!BOP
! !IROUTINE: ParExchangeLength --- Exchange a sparse packed vector
!
! !INTERFACE:  
      SUBROUTINE ParExchangeLength ( InComm, LenInVector, LenOutVector)

! !USES:
      IMPLICIT NONE

! !INPUT PARAMETERS:
      INTEGER, INTENT( IN )   :: InComm            ! Communicator
      INTEGER, INTENT( IN )   :: LenInVector( * )  ! Length on each PE

! !OUTPUT PARAMETERS:
      INTEGER, INTENT( OUT )  :: LenOutVector( * ) ! Length on each PE

! !DESCRIPTION:
!
!     This routine exchanges vectors stored in compressed format, i.e.,
!     in so-called compressed sparse row (CSR) format, with other
!     PEs.  In essence it first exchanges the lengths with
!     MPI\_Alltoall, then the exchange of the actual vectors (can be
!     different in size) using MPI\_AlltoallV.  Since the latter is
!     inefficient, it is simulated using MPI\_Isend and MPI\_Recv.
!
! !SYSTEM ROUTINES:
!     MPI_ISEND, MPI_RECV, MPI_WAITALL, MPI_ALLTOALL
!
! !REVISION HISTORY:
!   98.03.17   Sawyer     Creation from F77 version
!   98.03.30   Sawyer     Removed assumed shape arrays due to problems
!   99.01.18   Sawyer     Added barrier for safety
!   99.03.08   Sawyer     USE_SHMEM version for CRAY only; untested
!   99.06.01   Sawyer     USE_SHMEM version revised per comments from Tom
!   00.07.28   Sawyer     Implemented with shared memory arenas
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      INTEGER :: i, iscnt, ircnt, nr, pe, icnt, Nsize, Iam, Ierr
      INTEGER :: Status(MPI_STATUS_SIZE)
      Integer, allocatable :: Reqs(:), Stats(:)

      CPP_ENTER_PROCEDURE( "PAREXCHANGELENGTH" )

      CALL MPI_COMM_SIZE( InComm, Nsize, Ierr )
      CALL MPI_COMM_RANK( InComm, Iam, Ierr )

      allocate (Reqs(Nsize))
      allocate (Stats(Nsize*MPI_STATUS_SIZE))

#if defined( MY_ALLTOALL )
      DO pe = 0, Nsize-1
!
! Send the individual buffers with non-blocking sends
!
        nr = LenInVector( pe + 1 )
        CALL MPI_ISEND( nr, 1,                                           &
                        MPI_INTEGER, pe, Iam+3000,                       &
                        InComm, Reqs( pe+1 ), Ierr )
      ENDDO
      DO pe = 0, Nsize - 1
!
! Receive the buffers with MPI_Recv. Now we are blocking.
!
        CALL MPI_RECV( nr, 1,                                                 &
                       MPI_INTEGER, pe, pe+3000,                              &
                       InComm, Status, Ierr )
        LenOutVector(pe + 1) = nr
      ENDDO
      CALL MPI_WAITALL( Nsize, Reqs, Stats, Ierr )

      deallocate (Reqs)
      deallocate (Stats)

#else
      CALL MPI_ALLTOALL( LenInVector, 1, CPP_MPI_INTEGER,                     &
                         LenOutVector, 1, CPP_MPI_INTEGER,                    &
                         InComm, Ierr )
#endif
      CALL MPI_BARRIER( InComm, Ierr )


      CPP_LEAVE_PROCEDURE( "PAREXCHANGELENGTH" )

      RETURN
!EOC
      END SUBROUTINE ParExchangeLength
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParCalcInfoDecompToGhost --- calculates info about the pattern
!
! !INTERFACE:
      subroutine ParCalcInfoDecompToGhost(InComm, DA,GB,Info)
!
! !USES:
      USE decompmodule, ONLY : DecompType,DecompInfo,DecompGlobalToLocal
      USE ghostmodule, ONLY : GhostType,GhostInfo
      IMPLICIT NONE

! !INPUT PARAMETERS:
      integer, intent(in)           :: InComm ! communicator
      type(DecompType), intent(in)  :: DA   ! Source Decomp Desc
      type(GhostType) , intent(in)  :: GB   ! Destination Ghost Desc

! !OUTPUT PARAMETERS:
      type (ParInfoType), intent(out) :: Info  ! Info structure
!
! !DESCRIPTION:
!     This routine calulcates the information about a communication 
!     pattern that transforms from one decomposition to another, 
!     i.e., a so-called "transpose".  This is a copy of an algorithm 
!     from the ParPatternDecompToGhost subroutine.
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE, MPI_COMM_RANK, MPI_ALLREDUCE
!
! !REVISION HISTORY:
!   07.09.04   Dennis     Creation based on algorithm in ParPatternDecompToGhost
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      integer :: nTags,oldpe,oldlocal,sTag,eTag,nCount
      integer :: j,pe,local,tag,ierr,iam,npes
      integer :: npesA,npesB,tmpA,tmp1B,tmp2B,tmp3B
      integer, allocatable :: sCount(:),rCount(:)
  
      call DecompInfo(DA,npesA,tmpA)
      call GhostInfo(GB,npesB,tmp1B,tmp2B,tmp3B)

      call MPI_COMM_SIZE(InComm,npes,ierr)
      call MPI_COMM_RANK(InComm,iam,ierr)

      allocate(sCount(npes),rCount(npes))
      sCount=0
      rCount=0
      if(iam .lt. npesB)  then 
! Parse through all the tags in the local segment
        nTags = SIZE(GB%Local%Head(iam+1)%StartTags)
        do j=1,nTags
          oldpe = -1
          oldlocal = 0 
          sTag = GB%Local%Head(iam+1)%StartTags(j)
          eTag = GB%Local%Head(iam+1)%EndTags(j)
          do tag = sTag,eTag
            if(tag > 0) then 
!
! Determine the index and PE of this entry on A. This might be inlined later
!
              call DecompGlobalToLocal(DA,tag,Local,Pe)
!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
              if( pe /= oldpe .or. local /= oldlocal+1) then 
                sCount(pe+1) = sCount(pe+1) + 1
              endif
              oldpe = pe  ! Update PE
              oldlocal = local  ! Update local index
            endif
          enddo
        enddo
      endif
      
! Calculate the length of receive segments
      call ParExchangeLength(InComm,sCount,rCount)
!  Record some information 
      Info%numSendSeg   = SUM(sCount)
      InFo%numSendNeigh = COUNT(sCount > 0) 

      Info%numRecvSeg   = SUM(rCount)
      InFo%numRecvNeigh = COUNT(rCount > 0) 
      nCount=MAX(Info%numSendSeg,Info%numRecvSeg)
      call MPI_ALLREDUCE(nCount,Info%maxNumSeg,1,INT4,MPI_MAX,InComm,ierr)

      deallocate(sCount,rCount)

      CPP_LEAVE_PROCEDURE( "PARCALCLENGTHDECOMPTOGHOST" )
      RETURN
!EOC
      end subroutine ParCalcInfoDecompToGhost
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP  
! !IROUTINE:   ParCalcInfoDecompToDecomp --- calculates info about the pattern
!
! !INTERFACE:
      subroutine ParCalcInfoDecompToDecomp(InComm, DA,DB,Info)
!     
! !USES:
      USE decompmodule, ONLY : DecompType,DecompInfo,DecompGlobalToLocal
      IMPLICIT NONE

! !INPUT PARAMETERS:
      integer, intent(in)           :: InComm  ! communicator
      type(DecompType), intent(in)  :: DA      ! Source Decomp Desc
      type(DecompType), intent(in)  :: DB      ! Destination Decomp Desc

! !OUTPUT PARAMETERS:
      type (ParInfoType), intent(out) :: Info  ! Info structure
!           
! !DESCRIPTION:
!     This routine calulcates the information about a communication
!     pattern that transforms from one decomposition to another,
!     i.e., a so-called "transpose".  This is a copy of an algorithm
!     from the ParPatternDecompToDecomp subroutine.
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE, MPI_COMM_RANK, MPI_ALLREDUCE
!
! !REVISION HISTORY:
!   07.09.04   Dennis     Creation based on algorithm in ParPatternDecompToDecomp
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      integer :: nCount,npes,iam,ierr
      integer :: nTags,oldpe,oldlocal,sTag,eTag
      integer :: j,pe,local,tag,tmpA,tmpB,npesA,npesB
      integer, allocatable :: sCount(:),rCount(:)

      call DecompInfo(DA,npesA,tmpA)
      call DecompInfo(DB,npesB,tmpB)

      call MPI_COMM_SIZE(InComm,npes,ierr)
      call MPI_COMM_RANK(InComm,iam,ierr)
  
      allocate(sCount(npes),rCount(npes))
      sCount=0
      rCount=0
      if(iam .lt. npesB)  then
! Parse through all the tags in the local segment
        nTags = SIZE(DB%Head(iam+1)%StartTags)
        do j=1,nTags
          oldpe = -1
          sTag = DB%Head(iam+1)%StartTags(j)
          eTag = DB%Head(iam+1)%EndTags(j)
          do tag = sTag,eTag
!
! Determine the index and PE of this entry on A. This might be inlined later
!
            call DecompGlobalToLocal(DA,tag,Local,Pe)
!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
            if( pe /= oldpe ) then 
              oldpe = pe
              sCount(pe+1) = sCount(pe+1) + 1
            endif
          enddo
        enddo
      endif
! Calculate the length of recieve segments    
      call ParExchangeLength(InComm,sCount,rCount)      
!  Record some information
      Info%numSendSeg   = SUM(sCount)
      InFo%numSendNeigh = COUNT(sCount > 0)

      Info%numRecvSeg   = SUM(rCount)
      InFo%numRecvNeigh = COUNT(rCount > 0)
      nCount=MAX(Info%numSendSeg,Info%numRecvSeg)
      call MPI_ALLREDUCE(nCount,Info%maxNumSeg,1,INT4,MPI_MAX,InComm,ierr)
  
      deallocate(sCount,rCount)

      CPP_LEAVE_PROCEDURE( "PARCALCINFODECOMPTODECOMP" )
      RETURN
!EOC
      end subroutine ParCalcInfoDecompToDecomp
!--------------------------------------------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParCalcInfoGhostToDecomp --- calculates info about the pattern
!
! !INTERFACE:
      subroutine ParCalcInfoGhostToDecomp(InComm, GA,DB,Info)
!
! !USES:
      USE decompmodule, ONLY : DecompType,DecompInfo,DecompGlobalToLocal
      USE ghostmodule, ONLY : GhostType,GhostInfo
      IMPLICIT NONE

! !INPUT PARAMETERS:
      integer, intent(in)           :: InComm  ! communicator
      type(GhostType), intent(in)   :: GA      ! Source Ghost Desc
      type(DecompType), intent(in)  :: DB      ! Destination Decomp Desc

! !OUTPUT PARAMETERS:
      type (ParInfoType), intent(out) :: Info  ! Info structure
!
! !DESCRIPTION:
!     This routine calulcates the information about a communication
!     pattern that transforms from one decomposition to another,
!     i.e., a so-called "transpose".  This is a copy of an algorithm
!     from the ParPatternGhostToDecomp subroutine.
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE, MPI_COMM_RANK, MPI_ALLREDUCE
!
! !REVISION HISTORY:
!   07.09.04   Dennis     Creation based on algorithm in ParPatternGhostToDecomp
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      integer :: nTags,oldpe,oldlocal,sTag,eTag
      integer :: npes, nCount,iam,ierr
      integer :: j,pe,local,tag,npesA,npesB,tmpB,tmp1A,tmp2A,tmp3A
      integer, allocatable :: sCount(:),rCount(:)

      call GhostInfo(GA,npesA,tmp1A,tmp2A,tmp3A)
      call DecompInfo(DB,npesB,tmpB)

      call MPI_COMM_SIZE(InComm,npes,ierr)
      call MPI_COMM_RANK(InComm,iam,ierr)
  
      allocate(sCount(npes),rCount(npes))
      sCount=0
      rCount=0
      if(iam .lt. npesB) then 
! Parse through all the tags in the local segment
        nTags = SIZE(DB%Head(iam+1)%StartTags)
        do j=1,nTags
          oldpe = -1
          oldlocal = 0
          sTag = DB%Head(iam+1)%StartTags(j)
          eTag = DB%Head(iam+1)%EndTags(j)
          do tag = sTag,eTag
!
! Determine the index and PE of this entry on A. This might be inlined later
!
            call DecompGlobalToLocal(GA%Decomp,tag,Local,Pe)
!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
            if( pe /= oldpe .or. local /= OldLocal+1 ) then 
              sCount(pe+1) = sCount(pe+1) + 1
            endif
            oldpe = pe
            oldlocal = local
          enddo
        enddo
      endif
! Calculate the lenght of recieve segments
      call ParExchangeLength(InComm,sCount,rCount)
!  Record some information
      Info%numSendSeg   = SUM(sCount)
      InFo%numSendNeigh = COUNT(sCount > 0)

      Info%numRecvSeg   = SUM(rCount)
      InFo%numRecvNeigh = COUNT(rCount > 0)
      nCount=MAX(Info%numSendSeg,Info%numRecvSeg)
      call MPI_ALLREDUCE(nCount,Info%maxNumSeg,1,INT4,MPI_MAX,InComm,ierr)

      deallocate(sCount,rCount)

      CPP_LEAVE_PROCEDURE( "PARCALCLENGTHGHOSTTODECOMP" )
      RETURN
!EOC
      end subroutine ParCalcInfoGhostToDecomp
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
! !IROUTINE:   ParCalcInfoGhostToGhost --- calculates info about the pattern
!
! !INTERFACE:
      subroutine ParCalcInfoGhostToGhost(InComm, GA,GB,Info)
!
! !USES:
      USE decompmodule, ONLY : DecompGlobalToLocal
      USE ghostmodule, ONLY  : GhostType,GhostInfo
      IMPLICIT NONE

! !INPUT PARAMETERS:
      integer, intent(in)           :: InComm ! communicator
      type(GhostType), intent(in)   :: GA     ! Source Ghost Desc
      type(GhostType), intent(in)   :: GB     ! Destination Ghost Desc

! !OUTPUT PARAMETERS:
      type (ParInfoType), intent(out) :: Info  ! Info structure
!
! !DESCRIPTION:
!     This routine calulcates the information about a communication
!     pattern that transforms from one decomposition to another,
!     i.e., a so-called "transpose".  This is a copy of an algorithm
!     from the ParPatternGhostToGhost subroutine.
!
! !SYSTEM ROUTINES:
!    MPI_COMM_SIZE, MPI_COMM_RANK, MPI_ALLREDUCE
!
! !REVISION HISTORY:
!   07.09.04   Dennis     Creation based on algorithm in ParPatternGhostToGhost
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
      integer :: nTags,oldpe,oldlocal,sTag,eTag,ierr,nCount
      integer :: j,pe,local,tag,npes,iam,npesA,npesB
      integer :: tmp1A,tmp2A,tmp3A,tmp1B,tmp2B,tmp3B
      integer, allocatable :: sCount(:),rCount(:)

      call GhostInfo(GA,npesA,tmp1A,tmp2A,tmp3A)
      call GhostInfo(GB,npesB,tmp1B,tmp2B,tmp3B)

      call MPI_COMM_SIZE(InComm,npes,ierr)
      call MPI_COMM_RANK(InComm,iam,ierr)
  
      allocate(sCount(npes),rCount(npes))
      sCount=0
      rCount=0 
      if(iam .lt. npesB) then 
! Parse through all the tags in the local segment
        nTags = SIZE(GB%Local%Head(iam+1)%StartTags)
        do j=1,nTags
          oldpe = -1
          oldlocal = 0
          sTag = GB%Local%Head(iam+1)%StartTags(j)
          eTag = GB%Local%Head(iam+1)%EndTags(j)
          do tag = sTag,eTag
            if (Tag > 0 ) THEN 
!
! Determine the index and PE of this entry on A. This might be inlined later
!
              call DecompGlobalToLocal(GA%Decomp,tag,Local,Pe)
!
! If ipe-1 is my id, then this is an entry ipe will receive from Pe
!
              if( pe /= oldpe .or. local /= OldLocal+1 ) then 
                sCount(pe+1)=sCount(pe+1)+1
              endif
              oldpe = pe
              oldlocal = local
            endif
          enddo
        enddo
      endif

! Calculate the length of receive segments
      call ParExchangeLength(InComm,sCount,rCount)
!  Record some information
      Info%numSendSeg   = SUM(sCount)
      InFo%numSendNeigh = COUNT(sCount > 0)

      Info%numRecvSeg   = SUM(rCount)
      InFo%numRecvNeigh = COUNT(rCount > 0)
      nCount=MAX(Info%numSendSeg,Info%numRecvSeg)
      call MPI_ALLREDUCE(nCount,Info%maxNumSeg,1,INT4,MPI_MAX,InComm,ierr)

      deallocate(sCount,rCount)

      CPP_LEAVE_PROCEDURE( "PARCALCINFOGHOSTTOGHOST" )
      RETURN
!EOC
      end subroutine ParCalcInfoGhostToGhost
# endif
#endif
      END MODULE parutilitiesmodule
